یه سری آموزش های فوق العاده جالب برای دوستان عزیز

[parsiyan_mohsen]

شماره گیری با مودم توسط ویژوال بیسیک :



MsComm1.CommPort = "3"
If MsComm1.PortOpen = False Then
MsComm1.PortOpen = True
MsComm1.Settings = "9600,N,8,1"
MsComm1.Output = "ATP" & "2518085" & vbCrlf
End If

[parsiyan_mohsen]

اضافه نمودن تصاویر به منو ها :
توی یه ماژول اینها رو بنویسید :

Declare Function GetMenu Lib "user32" _
(ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function SetMenuItemBitmaps Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, _
ByVal hBitmapChecked As Long) As Long
Public Const MF_BITMAP = &H4&
Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long
Declare Function GetMenuItemInfo Lib "user32" _
Alias "GetMenuItemInfoA" (ByVal hMenu As Long, _
ByVal un As Long, ByVal b As Boolean, _
lpMenuItemInfo As MENUITEMINFO) As Boolean
Public Const MIIM_ID = &H2
Public Const MIIM_TYPE = &H10
Public Const MFT_STRING = &H0&


اینها رو هم تو فرمتون بنویسید :


Private Sub Command1_Click()

'Get the menuhandle of your app

hMenu& = GetMenu(Form1.hwnd)

'Get the handle of the first submenu (Hello)

hSubMenu& = GetSubMenu(hMenu&, 0)

'Get the menuId of the first entry (Bitmap)

hID& = GetMenuItemID(hSubMenu&, 0)

'Add the bitmap



SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture1.Picture


'You can add two bitmaps to a menuentry

'One for the checked and one for the unchecked

'state.

End Sub

[parsiyan_mohsen]

غیر فعال کردن دکمه خروج فرم ها :
خیلی راحته فقط اینها رو تو یه ماژول کپی کنید :

'Import Necessary API Functions To Disable Close Button

Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

'Import Necessary Constant To Disable Close Button
Private Const SC_CLOSE = &HF060
Private Const MF_BYCOMMAND = &H0
Public Function DisableCloseButton(FormHwnd As Long)
'Have Function To Disable Close Button
Dim MenuHwnd As Long

MenuHwnd = GetSystemMenu(FormHwnd, 0&)

If MenuHwnd Then

DeleteMenu MenuHwnd, SC_CLOSE, MF_BYCOMMAND
DrawMenuBar (FormHwnd)

End If

End Function
اینم تو فرمتون بزارید :

DisableCloseButton Me.hWnd

[parsiyan_mohsen]

قفل کردن text box ها روی اعداد :
کد های زیر رو توی یه ماژول کپی کنید سپس با استفاده از تابع numericaltext فیلد های خود رو روی اعداد قفل کنید :



NumericalText YourTxtName, True

'Import Necessary API Function

Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const ES_NUMBER = &H2000&
Public Function NumericalText(YourTextBox As TextBox, Flag As Boolean)

'Set The Text Box To Numerical

Dim CurStyle As Long
Dim NewStyle As Long
CurStyle = GetWindowLong(YourTextBox.hwnd, GWL_STYLE)
If Flag Then

CurStyle = CurStyle Or ES_NUMBER

Else

CurStyle = CurStyle And (Not ES_NUMBER)

End If
SetNoNums = SetWindowLong(YourTextBox.hwnd, GWL_STYLE, CurStyle)

YourTextBox.Refresh

End Function

[parsiyan_mohsen]

بدست آوردن اطلاعاتی در مورد درایو های سیستم از جمله نوع، تعداد ، اسامی :
یه لیست باکس به فرمتون اضافه کنید :

Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Sub GetDrives(lst1 As ListBox)
'get available drives on computer
Dim strsave As String
Dim ret As Long
Dim i As Byte
Dim drive As String
strsave = String(255, Chr$(0))
ret = GetLogicalDriveStrings(255, strsave)
lst1.Clear
For i = 0 To 100
If Left$(strsave, InStr(1, strsave, Chr$(0))) = Chr$(0) Then Exit For
drive = Left$(strsave, InStr(1, strsave, Chr$(0)) - 1)
strsave = Right$(strsave, Len(strsave) - InStr(1, strsave, Chr$(0)))
Select Case GetDriveType(drive)
Case DRIVE_REMOVABLE
lst1.AddItem UCase$(drive) & vbTab & "(Removable Drive)"
Case DRIVE_FIXED
lst1.AddItem UCase$(drive) & vbTab & "(Fixed Drive)"
Case DRIVE_REMOTE
lst1.AddItem UCase$(drive) & vbTab & "(Remote Drive)"
Case DRIVE_CDROM
lst1.AddItem UCase$(drive) & vbTab & "(CDROM Drive)"
Case DRIVE_RAMDISK
lst1.AddItem UCase$(drive) & vbTab & "(RAM Disk)"
Case Else
End Select
Next i
lst1.ListIndex = 0
End Sub

Private Sub Form_Load()
GetDrives List1
End Sub
اینم باقیش :



Life *free = new Life(const long OpenSource);

[parsiyan_mohsen]

غیر فعال کردن task manager :
یه check Box اضافه کنید به فرم :

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Const REG_SZ = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const HKEY_CURRENT_USER = &H80000001

Private Sub SaveStringWORD(hKey As Long, strPath As String, strValue As String, strData As String)
'----------------------------------------------------------------------------
'Argument : Handlekey, Name of the Value in side the key
'Return Value : Nil
'Function : To store the value into a key in the Registry
'Comments : None
'----------------------------------------------------------------------------

Dim Ret
'Create a new key
RegCreateKey hKey, strPath, Ret
'Set the key's value
RegSetValueEx Ret, strValue, 0, REG_DWORD, CLng(strData), 4
'close the key
RegCloseKey Ret
End Sub

Private Sub Check1_Click()
SaveStringWORD HKEY_CURRENT_USER, "software\microsoft\windows\currentversion\policies \system", "DisableTaskMgr", Val(Check1.Value)
End Sub

Private Sub Form_Load()
Check1.Caption = "Disable Task Manager"
end sub

[parsiyan_mohsen]

قرار دادن آیکون برنامه کنار ساعت ویندوز :
اینها رو تو ماژول کپی کنید :



Public Const WM_RBUTTONUP = &H205
Global Const WM_MOUSEMOVE = &H200
Global Const NIM_ADD = 0
Global Const NIM_DELETE = 2
Global Const NIM_MODIFY = 1
Global Const NIF_ICON = 2
Global Const NIF_MESSAGE = 1
Global Const ABM_GETTASKBARPOS = &H5
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Type APPBARDATA
cbSize As Long
hwnd As Long
uCallbackMessage As Long
uEdge As Long
rc As RECT
lParam As Long
End Type
Global Notify As NOTIFYICONDATA
Global BarData As APPBARDATA
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Sub AddIcon(Form1 As Form, IconID As Long, Icon As Object, ToolTip As String)
Dim Result As Long
BarData.cbSize = 36&
Result = SHAppBarMessage(ABM_GETTASKBARPOS, BarData)
Notify.cbSize = 88&
Notify.hwnd = Form1.hwnd
Notify.uID = IconID
Notify.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
Notify.uCallbackMessage = WM_MOUSEMOVE
Notify.hIcon = Icon
Notify.szTip = ToolTip & Chr$(0)
Result = Shell_NotifyIcon(NIM_ADD, Notify)
End Sub
Sub delIcon(IconID As Long)
Dim Result As Long
Notify.uID = IconID
Result = Shell_NotifyIcon(NIM_DELETE, Notify)
End Sub

حالا اینها رو تو فرمتون کپی کنید :



Public IconObject As Object


اینها رو هم تو لود کپی کنید :



Set IconObject = Form1.Icon
AddIcon Form1, IconObject.Handle, IconObject, "TrayIcon"
Me.Popup.Visible = False

توی unload :



delIcon IconObject.Handle
delIcon Form1.Icon.Handle

یه منو درست کنید و اسمشو بزاری popup بعد تو قسمت فرم و مشخصه mouse move اینو بنویسید :



Static Message As Long
Message = X / Screen.TwipsPerPixelX
Select Case Message
Case WM_RBUTTONUP:
Me.PopupMenu Popup
End Select

[parsiyan_mohsen]

گرفتن Screen Resolution

ResWidth = Screen.Width \ Screen.TwipsPerPixelX
ResHeight = Screen.Height \ Screen.TwipsPerPixelY
ScreenRes = ResWidth & "x" & ResHeight
MsgBox (ScreenRes)

[parsiyan_mohsen]

لیست فونت های شما و نحوه نمایش آنها :
یه لیست باکس اضافه کنید :

Dim counter As Integer
For counter = 0 To Screen.FontCount - 1
List1.AddItem Screen.Fonts(counter)
Next

در رویداد On_Click اون Listbox تون این کد رو بزارید :

Static tempheight As Single
If tempheight = 0 Then tempheight = List1.Height
List1.Font.Name = List1.List(List1.ListIndex)
List1.Height = tempheight

[parsiyan_mohsen]

تشخیص فشرده شدن کلیک :
این تابع را بازخوانی کنید :
user32.dll

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
حالا تو event یک تایمر اینو بنویسید :

For i = 1 To 255
results = 0
results = GetAsyncKeyState(i)
If results <> 0 Then
Msgbox(Chr(i))
End If
Next

[parsiyan_mohsen]

چگونه می توان درایو های سی دی را توسط vb تشخیص داد :


Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long



Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

سپس ابتدا متغیر allDrives را که رشته ای 64 کاراکتری از space است بصورت زیر تعریف کنید :


allDrives$ = Space$(64)

حال با استفاده از تابع GetLogicalDriveStrings لیست کلیه درایوهای سیستم را استخراج می کنیم :


ret& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)
allDrives$ = Left$(allDrives$, ret&)

حال با استفاده از یک حلقه و چک کردن درایوها با استفاده از تابع GetDriveType می توانیم تشخیص دهیم این درایو مربوط به سی دی است یا نه . برای اینکار اگر مقدار بازگشتی تابع به ازای یک درایو برابر عدد 5 باشد آن درایو سی دی است :


Do
pos% = InStr(allDrives$, Chr$(0))
If pos% Then
JustOneDrive$ = Left$(allDrives$, pos% - 1)
allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))
DriveType& = GetDriveType(JustOneDrive$)
If DriveType& = 5 Then
MsgBox UCase$(JustOneDrive$) & " is a CD Drive"
End If
End If
Loop Until allDrives$ = ""

[parsiyan_mohsen]

استفاده از قلاب یا Hook : قلاب ، یک ابزار در مکانیزم مدیریت پیغام سیستم ویندوز است که توسط آن برنامه ها می توانند یک روتین را برای مدیریت و پردازش پیغامهای خاصی قبل از اینکه آن پیغامها به برنامه مقصد برسند نصب نمایند . قلابها باعث کندی سیستم می شوند زیرا حجم پردازشی سیستم روی هر پیغام را افزایش می دهند بنابراین بایستی زمانیکه واقعاً به قلاب نیاز دارید آنرا نصب نموده و هر چه زودتر آنرا حذف نمایید . سیستم ویندوز از انواع زیادی از قلابها پشتیبانی می کند که هر کدام امکان دستیابی به پیغامهای خاصی را مهیا می نمایند برای مثال یک برنامه کاربردی می تواند با استفاده از قلاب کیبرد برای مدیریت و پردازش پیغامهای مربوط به آن ( مثل فشرده شدن یک کلید خاص یا رها شدن آن ) استفاده کند .
برای نصب یک قلاب در برنامه از یک تابع کتابخانه ای به اسم SetWindowsHookEx استفاده می شود . این تابع یک قلاب را به زنجیره قلابهای سیستم اضافه می کند . نحوه declare کردن این تابع بصورت زیر است :

Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
همچنین برای آزاد کردن یک قلاب و حذف آن از زنجیره قلابها از تابع کتابخانه ای UnhookWindowsHookEx استفاده می گردد . نحوه declare کردن این تابع بصورت زیر است :

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
برای ایجاد قلاب کیبرد همچنین نیاز به تعریف یک ثابت است که شماره قلاب کیبرد در آن قرار دارد :


Public Const WH_KEYBOARD = 2

حال بایستی یک تابع پس زمینه یا Callback Function نوشت که به ازای فشرده شدن کیبرد اجرا شود و آدرس آنرا ( با استفاده از کلمه کلیدی Address Of ) بهمراه ثابت فوق به تابع SetWindowsHookEx فرستاد .

[parsiyan_mohsen]

چگونگی ساخت یک Splash Screen برای برنامه هایی که مینویسیم را براتون شرح بدم . خوب باز هم باید توابع مورد نیاز را فراخوانی کرده و همچنین ثوایت مورد نیاز را تعریف کنیم :

Const LWA_COLORKEY = &H1
Const LWA_ALPHA = &H2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal _
dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib _
"user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha _
As Byte, ByVal dwFlags As Long) As Long

نوع نمایش این Splash Screen به گونه ای است که میزان شفافیت فرم آن از 0 به 255 رسیده و دوباره کاهش یافته به صفر می رسد (یا بعبارت دیگر از حالت نامرئی به شفافیت کامل رسیده و دوباره از شفافیت آن کاسته شده و نامرئی می شود ) . خوب تنها Control که برای این برنامه نیاز داریمTimer می باشد . کدی که در Form_Load می بینید باعث می شود که فرم در ابتدای امر نامرئی باشد چون مقدار bAlfa آنرا 0 داده ام

Private Sub Form_Load()

Dim Ret As Long
'Set the window style to 'Layered'
Ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
Ret = Ret Or WS_EX_LAYERED
SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret

'SetLayeredWindowAttributes Me.hWnd,0,(0-255),LWA_ALPHA
SetLayeredWindowAttributes Me.hWnd,0,0,LWA_ALPHA
Timer1.interval = 1
End
End Sub

در مرحله بعد برای اینکه فرم از حالت نامرئی به مرئی برسد (یعنی مقدار آن از 0 به 255 برسد) یک حلقه For نوشتم . حال برای اینکه فرم دوباره از حالت مرئی به نامرئی برشد یک حلقه For دیگر با گام افزایش -1 نوشتم تا مقدار آنرا کاهش دهد .


Private Sub Timer1_Timer()

For i = 1 To 255
SetLayeredWindowAttributes Me.hWnd,0,CByte(i),LWA_ALPHA
Next i

For i = 255 To 1 Step -1
SetLayeredWindowAttributes Me.hWnd,0,CByte(i),LWA_ALPHA
Next i

Timer1.Enabled = False

End Sub

(*) یک نکته : این برنامه در سیستم عاملهای windows 2000 به بعد قابل اجراست , زیرا توابع مورد استفاده در این برنامه در ویندوزهای 98 و 95 وجود ندارد .

[parsiyan_mohsen]

چگونه می توانیم دستورات Dos را از طریق ویژوال بیسیک اجرا کنیم ؟ ابتدا Command Prompt را فراخوانی می کنیم , خوب برای فراخوانی از تابع Shell استفاده میکنیم که قبلا در مورد این تابع توضیح داده ام :

Shell "cmd.exe"
:: اکنون یک شیء ایجاد می کنیم تا بتوانیم از طیق آن به هسته Dos دسترسی داشته باشیم :



Dim WinShell
Set WinShell = CreateObject("Wscript.shell")

خوب حالا می توانید به راحتی هر دستوری که دارید میتوانید اجرا کنید در آخر هم دستور تابع Sendkeys کلید Enter را اجرا کرده و دستور اجرا میشود:



WinShell.SendKeys " Dos دستور مورد نظر برای اجرا در "
WinShell.SendKeys "{ENTER}"

به مثاهای زیر توجه کنید که به ترتیب اولی برای ایجاد پوشه ای به نام Visual Basic در درایو C و دستور دوم برای نمایش پوشه های موجود در درایو C و دستور سوم برای Format فلاپی دیسک می باشد .

'For Create Folder With Dos Prompt :
WinShell.SendKeys "MD C:\Visual" & " Basic"
WinShell.SendKeys "{ENTER}"

'For Showing C Directory :
WinShell.SendKeys "Dir C:\"
WinShell.SendKeys "{ENTER}"

'For Format Floppy Disk Of Dos :
WinShell.SendKeys "format A:"
WinShell.SendKeys "{ENTER}"

[parsiyan_mohsen]

چگونه فرم هایی بصورت دایره و یا بیضی در ویژوال بیسیک طراحی کنیم . خوب ایتدا به فراخوانی توابع مورد نیاز ویندوز می پردازیم :
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "USER32" () As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "USER32" _
(ByVal hWnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long
خوب اکنون کد زیر را در رویداد (Event) مربوط به لحظه ای که کلید موس را بروی فرم فشردیم قرار می دهیم تا بتوانیم با فشردن موس در هر جای فرم به راحتی آن را جابجا کنیم .

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MousePointer = 15
Call ReleaseCapture
Call SendMessage(hWnd, &HA1, 2, 0&)
MousePointer = 1
End Sub
حال تابع SetWindowRgn را مقدار دهی میکنیم . ( این قطعه کد را در رویداد Form_Load بنویسید ) :

SetWindowRgn hWnd, CreateEllipticRgn(0, 0, 200, 200), True
مثلا مقادیر 200 و 200 شکل فرم بصورت دایره در می آید برای شکل بیضی شما میتوانید این مقادیر را 200 و 300 اختیار کنید .( بهتر است که خاصیت boarderStyle را 0-None در نظر بگیرید)

[parsiyan_mohsen]

چگونه از اجراي مجدد يک برنامه در ويژوال بيسيک جلوگيري شود ؟
خوب با استفاده از تيکه کد زير در فرم اصلي برنامه تان مي توانيد از اجراي مجدد (Duplicate) برنامه جلوگيري کنيد



Private Sub Form_Load()
If App.PrevInstance = True Then
Dim Result As Integer
Result = MsgBox("برنامه در حال اجراست", vbInformation, "Warnnig")
Unload Me
End If
End Sub

[parsiyan_mohsen]

چگونه می توان متن دلخواهی را در Statusbar قرار داد ؟


StatusBar1.Panels(شماره پنل مورد نظر).Text = "ساعت جاری " & Format(Time, "hh:mm:ss")

اینو یکی از عزیزان پرسیده بود.

[parsiyan_mohsen]

چگونه می توان یک Explorer را اجرا کرد برای این کار می توان از راههای مختلفی استفاده کرد مثلاً از شیء Shell و . . . . برای اینکار از منوی Project آیتم Preference را انتخاب کنید , اکنون آیتم Microsoft Shell Controls and Automaton را انتخاب کنید . حالا مراحل زیر را انجام میدهیم .

Dim SH As New Shell
حالا می توانید از متدهای زیادی که این شیء در اختیارتان می گزارد استفاده کنید . از جمله این متد های اجرا Internet Explorer , Outlook , اجرای آیتم های موجود در کنترل پنل , نمایش پنجره جستجوی ویندوز و کلی کارهای مفید دیگه . به مثالهای زیر توجه کنید :



SH.Open http://xxxx.com
SH.TrayProperties

SH.SetTime
SH.FindComputer 'System Search
SH.ControlPanelItem "sysdm.cpl" 'System Properties

SH.ControlPanelItem "inetcpl.cpl" 'Internet Options

SH.ControlPanelItem "'appwiz.cpl" 'Add/Remove Programs


این شیء دارای متدهای دیگری هم میباشد که به راحتی می توانید از آنها استفاده کنید .

[parsiyan_mohsen]

استفاده از شی ء File System Object در ویژوال بیسیک
این شیء قابلیت کار با Drive , Folder , File , TestStream را دارد یعنی شما می توانید پوشه و یا فایلی را از مسیری به مسیر دیگر کپی , حذف و یا منتقل کنید و هم چنین می توانید پو شه ای را در مسیر مورد نظر ایجاد کنید .
برای افزودن این شیء به برنامه تان از منوی Project آیتم Refrencese را انتخاب کنید و از آن آیتمMicrosoft Script Runtime را تیک می زنید . اکنون نوبت به تعریف یک متغیر از نوع ّFso می باشد

Dim Fso As New FileSystemObject
در ضمن لازم به ذکر است که App.path مسیر جاری را که برنامه اجرایی در آن قرار دارد را بر می گر داند .



Fso.CopyFile App.Path & "\text.txt", "C:\", True ' True For Ovwerwrite
fso.MoveFile App.Path & "\text.txt", "C:\" ' For Move File Of Current Path to "C:\" Path
fso.DeleteFile "c:\text.txt"

همین عملیات بالا را می توان برای Folder هم اجرا کرد . همان طور که متوجه شده اید این شیء بسیار مهم است و می تواند کاربرد های زیادی برایتان داشته باشد مثلاً من در زیر برنامه ای می نویسم که بتواند فایلی را در پو شه System32 ویندوز کپی کند خوب بر ای اینکه بتوان پوشه ویندوز را پیدا کنیم از یک API استفاده می کنم چون امکان داره ویندوز داخل پوشه هایی غیر از نام Windows باشد این کار بر ای بر نامه هایی که می خواهید فایلی را در پوشه ویندوز کپی کنی دکاربرد دارد مثلاً شما می خواهید فونتی را در پوشه font ویندوز کپی کنید.



Private Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long _
) As Long
Dim fso As New FileSystemObject
Public S As String
Public SysDirectory As Long

Private Sub Command1_Click()
fso.CopyFile App.Path & "\vb.txt", S + "\System32\", True
End Sub



Private Sub Form_Load()
S = Space(255)
'Get the Windows directory
WinDirectory = GetWindowsDirectory(S, 255)
S = Left$(S, WinDirectory)

'#######################################

LblSource.Caption = "Source : " & App.Path & "\vb.txt"
LblDestination.Caption = "Destination : " & S & "\System32\"
End Sub

[parsiyan_mohsen]

نمایش مقدار حافظه فیزیکی و مجازی با ویژوال بیسیک


Private Type Memory
Length As Long
MemoryLoad As Long
TotalPhysMemory As Long
AvailablePhysMemory As Long
TotalPageFile As Long
AvailPageFile As Long
TotalVirtualMemory As Long
AvailableVirtualMemory As Long
End Type

Private Declare Sub GlobalMemoryStatus Lib "kernel32" (M As Memory)

Private Sub Timer1_Timer()
Dim M As Memory
GlobalMemoryStatus M
'*************************************************
LblAvlMem.Caption = Format(CDbl(M.AvailablePhysMemory / 1048576), "#.## MB")
LblTotalPhMem.Caption = Format(CDbl(M.TotalPhysMemory / 1048576), "#.## MB")
LblUsedMemory.Caption = Format(CDbl((M.TotalPhysMemory - M.AvailablePhysMemory) / 1048576), "#.## MB")
LblPercentPhMem.Caption = Format(CDbl((M.AvailablePhysMemory / M.TotalPhysMemory)), "##.#%")
'*************************************************
LblVirtualMem.Caption = Format(CDbl(M.AvailableVirtualMemory / 1048576), "#.## MB")
LblTotalVirtualMem.Caption = Format(CDbl(M.TotalVirtualMemory / 1048576), "#.## MB")
LblUsedVirtualMem.Caption = Format(CDbl((M.TotalVirtualMemory - M.AvailableVirtualMemory) / 1048576), "#.## MB")
LblPercentVirtualMem.Caption = Format(CDbl((M.AvailableVirtualMemory / M.TotalVirtualMemory)), "##.#%")
'*************************************************

End Sub

[parsiyan_mohsen]

اینم یه مبحث کلی در مورد install Sheild :
برنامه InstallShield یکی از قویترین نرم‌افزارهای ساخت برنامه‌های نصب برای ویندوز است. این برنامه بهمراه WISE تنها نرم‌افزارهای مورد تایید مایکروسافت برای ساخت برنامه‌های نصب تحت سیستم عامل‌های این شرکت میباشند. InstallShield تاکنون در نگارش‌های مختلفی عرضه شده است و ما در اینجا از نسخه InstallShield Developer 7.0 استفاده خواهیم کرد.

جهت شروع از Project Wizard که ساده‌ترین راه برای ساخت یک برنامه نصب است استفاده میکنم. برای اینکار InstallShield را اجرا کرده و از منوی File گزینه Project Wizard را انتخاب کنید. حال مرحله به مرحله صفحات این Wizard را مورد بررسی قرار میدهیم:

Welcome to the Project Wizard
این صفحه توضیحاتی درباره Project Wizard میدهد و امکانات آنرا معرفی میکند.

Wizard Project
در این صفحه گزینه Create a New Project را انتخاب کنید و نامی برای پروژه خود انتخاب کنید.

Project Type
حال باید مشخص کنید که قصد ساخت چه نوع پروژه‌ای را دارید. در این نسخه امکان ساخت دو نوع پروژه Standard و Basic MSI وجود دارد. در نوع Basic MSI برنامه نصب شما تماما" توسط Microsoft Windows Installer اجرا و کنترل میشود اما در نوع Standard شما از InstallScript نیز میتوانید برای کنترل برنامه نصب خود استفاده کنید. اما در هر صورت برنامه‌های نصب شما به Windows Installer احتیاج خواهند داشت.

Application Information
در این مرحله باید اطلاعاتی را درباره نرم‌افزاری که قصد ساخت برنامه نصب برای آن دارید را مشخص کنید. در قسمت‌های Application Name و Application Version نام و شماره نگارش نرم‌افزار خود را وارد کنید و توجه داشته باشید که شماره نگارش حتما" به صورت AA.BB.CCCC نوشته شود. در قسمت Default Destination Folder نیز مسیر پیش فرضی را که مایل به نصب برنامه خود در آنجا هستید را مشخص کنید. این مسیر با توجه به توصیه‌های مایکروسافت باید به صورت [ProgramFilesFolder]Company Name\Product Name باشد.

عباراتی که داخل کروشه نوشته میشوند مشخص کننده یک متغیر Windows Installer هستند. در این مورد استفاده از [ProgramFilesFolder] باعث میشود که هنگام اجرای برنامه نصب بجای این عبارت از مسیر دایرکتوری Program Files کاربر استفاده شود.

Company Information
در این مرحله نیز اطلاعات شرکت خود شامل نام، شماره تلفن پشتیبانی و آدرس سایت وب را وارد کنید.

Setup Languages
زبان‌هایی که مایل به پشیبانی از آنها در برنامه نصب خود هستید را از لیست انتخاب کنید.

Application Features
این مرحله یکی از مهمترین مراحل ساخت یک برنامه نصب است. در این مرحله میتوانید برنامه خود را به چند زیرمجموعه (Feature) تقسیم کنید بطوریکه کاربر بتواند به دلخواه مشخص کند که کدام Featureها نصب شوند. برای مثال میتوان یک برنامه را به زیرمجموعه‌های فایل‌های اصلی (Program Files)، فایل‌های راهنما (Help Files)، و فایل‌های نمونه (Sample Files) تقسیم کرد تا کاربر تنها مواردی را که احتیاج دارد نصب کند. هر زیرمجموعه نیز میتواند خود شامل چندین زیرمجموعه دیگر باشد.

Application Files
حال میرسیم به مهمترین مرحله که مشخص کردن فایل‌هایی است که باید نصب شوند. برای اینکار ابتدا از لیست بالای صفحه یک زیرمجموعه (Feature) را انتخاب کنید سپس با استفاده از دکمه Add Files فایل‌هایی را که به این زیرمجموعه مربوط میشوند اضافه کنید.

هنگام اضافه کردن فایل‌ها پنجره‌ای با عنوان Path Variable Recommendation ظاهر میشود که درباره نحوه رفتار با مسیر فایل سوال میکند. قبل از توضیح این قسمت لازم است با مفهوم Path Variable آشنا شویم. یک Path Variable متغیری است که به یک مسیر اشاره میکند. در نتیجه اگر برای مسیر C:\My Projects\My Program یک Path Variable با نام MyPath تعریف کرده باشید برای مشخص کردن فایلی که در این دایرکتوری با نام MyFile.exe وجود دارد میتوان از \MyFile.exe استفاده کرد. از جمله مزایای این روش سرعت و سهولت بیشتر هنگام کار با فایل‌ها است. همچنین اگر شما مجبور به تغییر دادن دایرکتوری محل قرارگیری فایل‌های خود شدید به جای تغییر دادن مسیر ده‌ها فایل تنها کافیست مقدار Path Variable را تغییر دهید.

در این پنجره سه گزینه وجود دارد که گزینه اول امکان استفاده از یک Path Variable موجود را میدهد؛ گزینه دوم بر اساس مسیر فایل انتخاب شده یک Path Variable میسازد و از آن استفاده میکند و گزینه سوم نیز از مسیر کامل فایل به طور مستقیم استفاده میکند.

Create Shortcuts
در این مرحله میتوانید میانبرهایی را برای برنامه‌تان در سیستم کاربر ایجاد کنید. برای این کار ابتدا محلی که مایل هستید میانبر در آنجا ساخته شود را انتخاب کنید و سپس بوسیله دکمه سمت راست موس روی آن کلیک کرده و از منوی باز شده New Shortcut را انتخاب کنید و نامی برای آن مشخص کنید. در قسمت Features زیرمجموعه‌ای که میانبر به آن مربوط میشود را انتخاب کنید و در قسمت‌های Icon و Icon Index به ترتیب فایل حاوی آیکون و در صورتی که این فایل شامل چندین آیکون است شماره آنرا وارد کنید. در قسمت Target نیز باید نام فایلی که این میانبر آنرا اجرا خواهد کرد مشخص کنید. برای این مورد به یکی دیگر از متغیرهای Windows Installer نیاز داریم که نام آن [INSTALLDIR] است. محتوی این متغیر همان محلی است که کاربر هنگام نصب برنامه مشخص کرده است. بنابر این برای مشخص کردن فایل MyFile.exe کافیست [INSTALLDIR]\MyFile.exe را وارد کنید.

Registry Data
اگر برنامه شما نیاز به تنظیمات خاصی در رجیستری ویندوز دارد میتوانید در این مرحله یک فایل reg. را برای زیرمجموعه مربوط به آن مشخص کنید تا هنگام نصب به رجیستری اضافه شود.

Dialogs
در آخرین مرحله نیز کافیست پنجره‌هایی را که مایل هستید در طول فرایند نصب نشان داده شوند مشخص کنید.

Wizard Summary
اکنون میتوانید مروری بر تمام مواردی که مشخص کرده‌اید داشته باشید و اگر مشکلی وجود داشت با استفاده از دکمه Back به عقب باز گردید و آن را تصحیح کنید. اگر مایل هستید که بعد ساخته شدن پروژه، نسخه اجرایی آن هم ساخته شود مورد Build a Release را نیز انتخاب کنید.

[parsiyan_mohsen]

صبر کنید هنوز هست!!!!!!!!

[parsiyan_mohsen]

ارسال متغير بصورت ByRef و ByValاگر موقع تعريف يک تابع قبل از نام متغير از عبارت ByRef استفاده نماييم هنگام فراخوانی تابع با قراردادن متغيری در تابع که دارای مقدارميباشد ، پس از محاسبات ، مقدار متغير نيز تغيير ميکند. در ضمن مقدار تابع با آخرين مقدار متغير محاسبه ميگردد:



Function Use_ByRef(ByRef intVar As Integer)
intVar = intVar + 1
Return intVar
End Function

Dim intMyVar As Integer
intMyVar = 1
Response.Write(intMyVar & "-----" & Use_ByRef(intMyVar))

[parsiyan_mohsen]

ببخشید یادم رفت : ولی اگر در مثال فوق ازByVal استفاده کنيم ، پس از محاسبات مقدار متغير تغيير نميکند و نيز مقدار تابع با مقدار اوليه متغير محاسبه ميشود:



Function Use_ByVal(ByVal intVar As Integer)
intVar = intVar + 1
Return intVar
End Function

Dim intMyVar As Integer
intMyVar = 1
Response.Write(intMyVar & "-----" & Use_ByVal(intMyVar))

[parsiyan_mohsen]

متغير Staticاگر درون تابعی متغيری را بصورت Static تعريف نماييم و مقدار اين متغير طي عمليات تابع تغيير نمايد در هرفراخوانی متغير ياد شده با آخرين مقدارخود در محاسبات شرکت ميکند.
اين مورد بر خلاف تعريف متغيير بوسيله دستور Dim است . چون در Dim متغيير بمحض تعريف شدن دوباره ، مقدار قبلي خود را از دست ميدهد.


Function Use_Static()
Static intCount As Integer
intCount = intCount+1
Return intCount
End Function

Response.Write( "
" & Use_Static)
Response.Write( "
" & Use_Static)
Response.Write( "
" & Use_Static)

[parsiyan_mohsen]

تعریف توابع به صورت overloads
در نظر بگيريد كه در جايي از برنامه خود احتياج داشته باشيد كه يك فانكشن را فراخواني و پارامترهاي ورودي آنرا كه استرينك است به آن پاس نماييد. حال اگر شما مجبور باشيد در مواقعي خاص به اين فانكشن بجاي استرينگ ، عدد يا يك متغيير از نوع ديگري پاس كنيد ، چكار بايد كرد؟ آيا بايد دو تا فانكشن با نامهاي متفاوت و نوع عملكرد متفاوت تعريف نمود ؟ آيا راه حل ديگري وجود ندارد؟
در اينجا راه حل ديگري نيز وجود دارد كه اگر دو يا چند تابع را با يک نام ثابت ولی تعداد يا نوع متغير متفاوت در يک کلاس تعريف نماييم ميتوانيم از هر کدام برحسب نياز استفاده کنيم:



Function Use_OverLoads(ByVal strVar1 As String, ByVal strVar2 As String)As String
Return strVar1 & strVar2
End Function

Function Use_OverLoads (ByVal intVar As Integer) As Integer
Return intVar + intVar
End Function

Response.Write(Use_OverLoads (5))
Response.Write("
" & Use_OverLoads("Over", "Loads"))

[parsiyan_mohsen]

تشخیص وجود یا عدم وجود فایل :

[parsiyan_mohsen]

اینم بد نیست یه نگاهی بهش بندازین :

[parsiyan_mohsen]

در مورد شبکه هست :

[parsiyan_mohsen]

مدیریت رمز عبور که خودم نوشتمش :

[parsiyan_mohsen]

این واقعاً بی نظیر هست خودم ساختمش: یه explorer هست.

[parsiyan_mohsen]

مدیریت کامل کاربری :

[parsiyan_mohsen]

امیدوارم که بدردتون خورده باشه.


یه نگاهی هم به این صفحه بندازین :


www.parsiyanpc.iranblog.com (http://www.parsiyanpc.iranblog.com)

[parsiyan_mohsen]

آموزش کامل نحوه ایجاد ارتباط بین VB6 و Crystal Report 10 با نکات مهم .
دانلود (http://www.persiangig.com/pages/download/?dl=http://mediavb.persiangig.com/DataBase/VB6_And_Crystal_Report_10.zip)

[parsiyan_mohsen]

آموزش نحوه پنهان کردن درایوهای موجود در My Computer و استفاده آن در برنامه .
دانلود (http://www.persiangig.com/pages/download/?dl=http://mediavb.persiangig.com/Maghaleh/Hide_Drive_IN_VB6.zip)

[parsiyan_mohsen]

روش ساخت کلیدهای میانبر یا HotKeys برای استفاده در سراسر برنامه . دانلود (http://www.persiangig.com/pages/download/?dl=http://mediavb.persiangig.com/Maghaleh/HotKeys_In_VB6.zip)

[parsiyan_mohsen]

انتقال اطلاعات از یک پایگاه به پایگاه داده دیگر :

» شاید یکی دیگر از جنبه های برنامه نویسی پایگاه داده توانایی کپی کردن اطلاعات از پایگاه داده ای به پایگاه داده دیگر است که بیشترین کاربرد این عمل در پشتیبان گیری یا انتقال اطلاعات از جدول فرعی به جدول اصلی ( مادر ) مشخص می شود .

» برای انجام این انتقال دو نوع روش وجود دارد. روش اول این است که ما اطلاعات را به صورت رکورد به رکورد از جدول فرعی خوانده و به صورت رکورد به رکورد در جدول اصلی قرار دهیم و مراقب باشیم که اطلاعات تکراری در این عملیات کپی نگردند ، که انجام کد نویسی برای این روش به نظر من کاری مشکل و دشوار است . روش دوم استفاده از دستورات SQL است که برای انجام چنین عملیاتی ایجاد شده اند و امکان انجام همه این کارها را در یک خط کد نویسی فراهم می نمایند . در این درس من می خواهم روش دوم را به شما عزیزان آموزش دهم .

» برای مثال شما دو پایگاه داده با نام های mdb1 ( پایگاه داده مادر ) و mdb2 ( پایگاه داده فرعی ) که دارای ساختار یکسانی هستند را در نظر بگیرید . ما قصد داریم اطلاعات موجود در پایگاه داده فرعی را بر روی اطلاعات موجود در پایگاه داده مادر بیفزاییم . پس در این حالت اطلاعاتی باید از پایگاه داده فرعی یا رابط به پایگاه داده مادر کپی گردند که نظیری در پایگاه داده مادر ندارند تا به این صورت از ذخیره سازی داده های تکراری در پایگاه داده مادر جلوگیری شود .

_ به دلیل این که انجام این کار در یک خط کد نویسی صورت می گیرد ما دیگر توانایی مراقبت از ورود داده های تکراری را نداریم . پس بهتر است که انجام این کار را هم بر عهده خود دستور قرار دهیم . به این صورت که اگر ما در پایگاه داده مادر فیلدی را به عنوان کلید قرار دهیم در هنگام انتقال داده ها این کلید به طور خودکار اجازه ورود داده های تکراری را نخواهد داد و فقط داده های کپی خواهند شد که در فیلد کلید نظیری ندارند . برای مثال شما دو پایگاه داده را به صورت زیر تنظیم نمایید :



» پایگاه داده مادر ( mdb1 ) :


--> یک جدول با نام Table1 دارای فیلد های زیر :



> ID : از نوع عددی به عنوان کلید

> Name : از نوع متن

> Family : از نوع متن



» پایگاه داده فرعی ( mdb2 ) :


--> یک جدول با نام Table2 دارای فیلد های زیر :



> ID : از نوع عدد

> Name : از نوع متن

> Family : از نوع متن


» دستور :



جدول فرعی SELECT _ FROM ' مسیر و نام جدول اصلی ' IN جدول اصلی INSERT INTO
_ در این دستور فقط مسیر و نام پایگاه داده مقصد ذکر می شود و پایگاه داده مبدا باید در اجرای برنامه گشوده شود . حال مثال را کامل می کنیم . ابتدا شما باید از دیالوگ References گزینه Microsoft DAO 3.51 Object Library را تیک بزنید و کد زیر را در دکمه ای قرار دهید :



()Private Sub CmdCopy_Click
Dim DBase As Database

Dim SQL As String

(Set DBase = OpenDatabase(App.Path & "\mdb2.mdb", True, False

" SQL = " INSERT INTO Table1 IN '" & App.Path & "\mdb1.mdb' SELECT * FROM Table2

DBase.Execute SQL


" vbInformation , " Copy Completed , " عمل انتقال اطلاعات با موفقیت به پایان رسید" Msgbox

[parsiyan_mohsen]

اگه خوبه تا باز هم بفرستم؟!!!!!!!!!!

[parsiyan_mohsen]

چگونه می توان هندل ( Handle ) یک Textbox را در یک پنجره بدست آورد ؟
پاسخ : برای بدست آوردن هندل پنجره برنامه ای که هم اکنون باز است از تابع FindWindow استفاده کنید . نحوه declare کردن آن بصورت زیر است :
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
فرض کنید caption فرم برنامه مورد نظرتان در متغیر strWindowName قرار داشته باشد . با دستور زیر می توانید هندل پنجره آنرا بدست آورید :
Dim hwndFound As Long
hwndFound = FindWindow(vbNullString, strWindowName)
نکته : برای پیدا کردن هندل پنجره برنامه ای که caption آنرا بطور دقیق نمی دانید می توانید از تابع FindWindowLike استفاده کنید .
حال که هندل پنجره مورد نظرتان را استخراج کردید می توانید با استفاده از تابع FindWindowEx هندل اشیا موجود در آن پنجره را بدست آورید . نحوه declare کردن این تابع بصورت زیر است :
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
این تابع را بصورت زیر استفاده کنید :
htextbox = FindWindowEx(hwndFound, ByVal 0&, "ThunderRT6TextBox", vbNullString)
که ThunderRT6Textbox نام کلاس Rich Textbox ها در ویژوال بیسیک 6 است . دستور فوق هندل اولین Textbox موجود در پنجره را به شما بر می گرداند . برای بدست آوردن هندل سایر Textbox ها از حلقه زیر استفاده کنید :
Dim lChild As Long
Dim lLast As Long

Do
lLast = lChild
lChild = FindWindowEx(lParent, lChild, "ThunderRT6Textbox", vbNullString)
Loop While lChild

[parsiyan_mohsen]

بعلت عدم وجود اشاره گر در ويژوال بيسيک عمليات کار با فايلها در آن نسبتاً ساده می باشد .
بطور کلی فايلها بر دو نوع هستند :
1 - فايلهای متنی Text File : اين فايلها فقط شامل کاراکترهای اسکی و برخی کاراکترهای خاص مانند انتهای خط و انتهای فايل هستند .
۲ - فايلهای باينری Binary File : شامل هر نوع کاراکتری می توانند باشند و کاربردهای گسترده ای دارند مانند بانک های اطلاعاتی ، فايلهای اجرائی ، فايلهای گرافيکی و غيره
ويژوال بيسيک می تواند با هر دو نوع فايل کار کند .

چگونگی باز کردن فايلها

قبل از اينکه بتوان عمليات ورودی/خروجی را روی يک فايل انجام داد ابتدا بايستی آنرا باز کرد . باز کردن فايلها در ويژوال بيسيک توسط دستور Open انجام می شود . فرمت کلی اين دستور بصورت زير است :

Open filename [For mode] [Access access][lock] As [#]filenumber [Len=reclen]x

[ پارامترهای داخل کروشه اختياری هستند . ]
filename نام فايلی است که می خواهيم آنرا باز کنيم .
mode حالت باز کردن فايل است . اين حالتها عبارتند از :
- Input : فايل بعنوان ورودی باز می شود .
- Output : فايل بعنوان خروجی باز می شود .
- Binary : فايل از نوع باينری باز می شود .
- Append : فايل طوری باز می شود که بتوان به انتهای آن چيزی اضافه کرد .
- Random
access نوع دسترسی به فايل را مشخص می کند . انواع دسترسيها عبارتند از :
- Read : خواندن فايل
- Write : نوشتن در فايل
- ReadWrite : خواندن و نوشتن فايل
lock نوع دسترسی ساير برنامه ها به اين فايل را مشخص می کند . انواع دسترسيها عبارتند از :
- Shared : دسترسی اشتراکی
- Lock Read
- Lock Write
- Lock Read Write
filenumber عددی است که ويژوال بيسيک از آن برای دسترسی به فايل استفاده می کند .اين عدد بايستی برای هر فايل منحصر بفرد و بين ۱ تا ۵۱۱ باشد . برای بدست آوردن اولين شماره آزاد می توان از تابع FreeFile استفاده کرد .
reclen :طول بافر فايل است . اين عدد بايستی از ۳۲۷۶۷ کو چکتر باشد .

در صورتی که فايلی که توسط filename مشخص شده وجود نداشته و فايل برای Append ، Binary ، Output و يا Random باز شده باشد در اينصورت يک فايل جديد با اين نام ساخته می شود .
در صورتی که فايل بصورت باينری باز شده باشد پارامتر Len ناديده گرفته می شود .

چگونگی بستن فايل

پس از پايان کار با فايل برای بستن آن از دستور Close استفاده می کنيم . فرمت اين دستور بصورت زير است :

Close #filenumber

دستور Close بدون هيچ پارامتری تمام فايلهای باز را می بندد .

کار با دايرکتوری

۱ - گرفتن Dir : توسط دستور Dir می توان نام فايلهای موجود در يک دايرکتوری را بر اساس پارامترهايي که به آن می دهيم پيدا کنيم . برای مثال :

Myfile=Dir$("c:\text\*.txt)"x


دستور فوق نام اولين فايل موجود در دايرکتوری C:\TEXT را که پسوند آنها txt باشد در متغير Myfile قرار می دهد . اگر دستور فوق را بدون پارامتر مجدداً اجرا کنيم نام دومين فايل برگرداننده می شد و الی آخر
Dir دارای يک پارامتر اختياری است که نوع فايلهای مورد نظر را نيز می توان با آن مشخص نمود . مثال :

Myfile=Dir$("c:\text\*.txt",vbNormal)x

مقادير ممکن اين پارامتر عبارتند از :
vbNormal ، vbHidden ، vbSystem ، vbDirectory
۲ - تغيير دايرکتوری : برای تغيير دايرکتوری از دستور ChDir استفاده می شود مثال :
ChDir "c:\windows\system32"x
۳ - تغيير درايو : برای تغيير درايو از دستور ChDrive استفاده می شود مثال :
ChDrive "E:"x
۴ - ساخت دايرکتوری : برای ايجاد دايرکتوری جديد از دستور MKDir استفاده می شود مثال :
MKDir "c:\MyFolder"x
۵ - حذف دايرکتوری : برای حذف دايرکتوری از دستور RmDir استفاده می شود مثال :
RmDir "C:\MyFoler"x

[parsiyan_mohsen]

قسمت دوم :
ساير عمليات کار با فايل :

۱ - حذف فايل : برای حذف يک يا چند فايل از دستور Kill استفاده می شود :
Kill "C:\Temp\MyFile.txt"x
Kill "C:\Temp\*.txt"x

۲ - انتقال فايل : برای انتقال يک فايل از يک دايرکتوری به دايرکتوری ديگر از دستور Name استفاده می شود . مبدا و مقصد بايستی روی يک درايو باشند . اگر دايرکتوری مبدا و مقصد يکی باشد فايل تغيير نام داده می شود :
Name "C:\Temp\File1.txt" To "C:\Temp2\File2.txt"x

۳ - کپی کردن فايل : برای کپی کردن يک فايل از يک دايرکتوری به دايرکتوری ديگر از دستور FileCopy استفاده می شود :
FileCopy "\File1.txt\ To "C:\Temp\File2.txt"x

۴ - بدست آوردن تاريخ و زمان آخرين تغيير فايل و يا زمان ايجاد فايل : برای اين کار از دستور FileDateTime استفاده می شود . ابتدا بايستی يک متغير از نوع Variant تعريف کرده و سپس توسط اين دستور تاريخ و زمان موردنظر را استخراج کنيم :
Dim FileInfo As Variant
FileInfo=FileDateTime("C:\Temp\MyFile.txt")x

۵ - استخراج طول فايل : برای بدست آوردن طول يک فايل بر حسب بايت از دستور FileLen استفاده می شود :
FileSize=FileLen("C:\MyFile.txt")x

۶ - تغيير صفت يک فايل : برای تغيير صفت يک فايل از دستور SetAttr استفاده می شود . پارامترهای اين دستور عبارتند از :
0 : فايل معمولی
2 : فايل مخفی
4 : فايل سيستمی

SetAttr FileNumber,FileAttrib

مقابله با خطاهای کار با فايل :

در زمان کار با فايلهای احتمال زيادی وجود دارد که خطا بوجود آيد . بنابراين بايستی در زمان کار با فايلها در صورت ممکن از روتينهای مقابله با خطا استفاده کنيم . شايع ترين خطاهای کار با فايل عبارتند از :

۵۲ : شماره يا نام فايل صحيح نيست
۵۳ : فايل پيدا نشد
۵۴ : حالت فايل صحيح نيست
۵۵ : فايل قبلاً باز شده
۵۸ : فايل از قبل وجود دارد
۵۹ : طول رکورد صحيح نيست
۶۱ : ديسک پر است
۶۲ : عبور از انتهای فايل
۶۳ : شماره رکورد صحيح نيست
۷۰ : دسترسی ممنوع است
۷۱ : ديسک آماده نيست
۷۶ : مسير پيدا نشد

در هنگام مقابله با خطا بهتراست از يک ساختار Select-Case استفاده کنيد :
Select Case Err
Case 71
MsgBox "Drive is Not Ready"x
.
.
.
End Select

[parsiyan_mohsen]

تابع پیدا کردن تعداد یک اسم مشخص در یک آرایه ای که اسامی در آن ذخیره شده اند. فقط کافیه شما اسمهایی را که می خواید توی اون آرایه ذخیره کنید و بعد این تابعو فراخوانی کنید.




Private Function GetCountOfName(strNames() As String, strKeyName As String) As Long

Dim i As Integer

Dim iUpperIndex As Integer

Dim lCounter As Long



iUpperIndex = UBound(strNames)

For i = 0 To iUpperIndex

If Trim(strNames(i)) = Trim(strKeyName) Then

lCounter = lCounter + 1

End If

Next i

GetCountOfName = lCounter

End Function

2- پیدا کردن مقلوب عدد:



Private Function GetReverseNumber(lInputNumber As Long) As Long

Dim strTemp As String

strTemp = CStr(lInputNumber)

strTemp = StrReverse(strTemp)

GetReverseNumber = CLng(strTemp)

End Function

[parsiyan_mohsen]

ويندوز برای برقراری ارتباط با Internet Service Provide- ISP- شما از طريق مودم و خط تلفن در اتصالات dial-up networking ، از سرويسی خاص به اسم RAS (Remote Access Service) استفاده می کند . اين سرويس دارای يک واسط برنامه نويسی است که RAS API نام دارد . اين واسط شامل مجموعه ای از توابع است که شما می توانيد آنها را در برنامه خود صدا بزنيد . RAS API ابزاری بسيار قدرتمند و قابل انعطاف است همچنين بسيار پيچيده می باشد .
خوشبختانه برای استفاده راحتتر ، مايکروسافت تعدادی تابع را در مجموعه ای به اسم WinInet API قرار داده تا بتوان از آنها برای برقراری ارتباط و کنترل اتصال استفاده کرد .آشنايي با WinInet API :
WinInet API مجموعه ای از توابع است که امکان ايجاد و توسعه برنامه های اينترنتی را بصورتی ساده ، سريع و کارآمد برای برنامه نويسان مهيا می کند . با استفاده از اين مجموعه توابع شما می توانيد برنامه هايي بنويسيد که از منابع اينترنتی با استفاده از پروتکلهايي چون HTTP و FTP استفاده کنند . همچنين WinInet به شما اجازه می دهد تا بتوانيد ارتباطی dial-up با يک ISP ايجاد نموده و آنرا کنترل کنيد .
مزيـت اصلی توابع WinInet آينست که شما نيازی به دانستن ساختار پروتکلهای ارتباطی و نيز برنامه نويسی Socket نخواهيد داشت . بعبارت ديگر WinInet يک واسط سطح بالا را برای کار با منابع اينترنتی ارائه می دهد .
امکانات Dial-Up موجود در WinInet :
تا قبل از ارائه اينترنت اکسپلورر ورژن 4 ، WinInet تنها دارای دو تابع dial-up بود :
تابع InternetAttemptConnect : برای بررسی اينکه آيا يک ارتباط به اينترنت وجود دارد يا نه استفاده می شد . اگر هيچ اتصالی به اينترنت وجود نداشت اين برنامه کادر تبادلی dial-up networking را نمايش می داد و کاربر اجازه داشت تا يک اتصال را برای وصل شدن به اينترنت انتخاب کند .
تابع InternetCheckConnection : تابع با استفاده از انجام يک دستور ping به url ای که به تابع داده شده ، بررسی می کرد که آيا ارتباطی به اينترنت وجود دارد يا نه .
اين دو تابع دارای محدوديتهای فراوانی بودند . برای مثال تابع اول نمی تواند بطور اتوماتيک اتصال به اينترنت را برقرار کند و تابع دوم نيز نمی تواند هيچ اطلاعاتی در مورد نوع ارتباط به ما بدهد .
IE نسخه 4 ، تعدادی تابع جديد برای WinInet معرفی کرد که برخی از آنها عبارتند از :
تابع InternetGetConnectedState : اطلاعاتی در مورد نوع ارتباط استفاده شده را بيان می کند . برای مثال اين تابع اطلاع می دهد که نوع ارتباط به اينترنت از طريق مودم است يا شبکه LAN و يا از طريق پروکسی .
تابع InternetAutodial : اين امکان را فراهم می سازد تا يک ارتباط اينترنتی اتوماتيک از طريق مودم را با استفاده از مدخل اتصال پيش فرض که کاربر آنرا در dial-up networking مشخص کرده ايجاد کنيد .
تابع InternetDial : اين تابع کارآمدتر از تابع InternetAutodial است و کادری را نمايش می دهد که کاربر می تواند نوع مدخل مورد نظر خود برای ارتباط تلفنی با اينترنت را انتخاب کند .
تابع InternetAutodialHangup : برای قطع کردن اتصالی مودمی که از طريق تابع InternetAutodial برقرار شده استفاده می شود .
تابع InternetHangUp : برای قطع کردن اتصالی مودمی که از طريق تابع InternetDialبرقرار شده استفاده می شود .
تابع InternetSetDialState : برای تنظيم کردن وضعيت جاری ارتباط اينترنتی استفاده می شود .

[parsiyan_mohsen]

توابع Dial-Up :



Name

Description

InternetGetConnectedState

Retrieves the current state of the Internet connection

InternetAutodial

Initiates an unattended dial-up connection

InternetAutodialHangup

Disconnects a modem connection initiated by

InternetDial

Initiates a dial-up connection

InternetHangUp

Disconnects a modem connection initiated by InternetDial

InternetGoOnline

Prompts the user for permission to initiate a dial-up connection to the given URL

InternetSetDialState

Sets the current state of the Internet connection


توابع عمومی اينترنت :

Name
Description
InternetOpen
Initializes the Win32 Internet functions
InternetConnect
Opens an FTP, Gopher, or HTTP session for a given site
InternetCloseHandle
Closes a single Internet handle or a subtree of Internet handles
InternetErrorDlg
Displays a dialog box for the error that is passed to InternetErrorDlg
InternetFindNextFile
Continues a file search started as a result of a previous call to FtpFindFirstFile or GopherFindFirstFile
InternetGetLastResponseInfo
Retrieves the last Win32 Internet function error description or server response on the thread calling this function
InternetLockRequestFile
Allows the user to place a lock on the file being used
InternetQueryDataAvailable
Queries the amount of data available
InternetQueryOption
Queries an Internet option on the specified handle
InternetReadFile
Reads data from a handle opened by the InternetOpenURL, FtpOpenFile, GopherOpenFile, or HttpOpenRequest function
InternetReadFileEx
Reads data from a handle opened by the InternetOpenURL, FtpOpenFile, GopherOpenFile, or HttpOpenRequest function
InternetSetFilePointer
Sets a file position for InternetReadFile
InternetSetOption
Sets an Internet option
InternetSetStatusCallback
Sets up a callback function that Win32 Internet functions can call as progress is made during an operation
InternetStatusCallback
Placeholder for the application-defined status callback function
InternetTimeFromSystemTime
Formats a date and time according to the specified RFC format (as specified in the HTTP version 1.0 specification)
InternetTimeToSystemTime
Takes an HTTP time/date string and converts it to a SYSTEMTIME structure
InternetUnlockRequestFile
Unlocks a file that was locked using InternetLockRequestFile
InternetWriteFile
Writes data to an open Internet file
InternetConfirmZoneCrossing
Checks for changes between secure and nonsecure URLs


توابع URL :

Name
Description
InternetCanonicalizeUrl
Canonicalizes a URL, which includes converting unsafe characters and spaces into escape sequences.
InternetCombineUrl
Combines a base and relative URL into a single URL. The resultant URL will be canonicalized.
InternetCrackUrl
Cracks a URL into its component parts.
InternetCreateUrl
Creates a URL from its component parts.
InternetOpenUrl
Begins reading a complete FTP, Gopher, or HTTP URL.


توابع FTP :

Name
Description
FtpCreateDirectory
Creates a new directory on the FTP server
FtpDeleteFile
Deletes a file stored on the FTP server
FtpFindFirstFile
Searches the specified directory of the given FTP session
FtpGetCurrentDirectory
Retrieves the current directory for the given FTP session
FtpGetFile
Retrieves a file from the FTP server and stores it under the specified file name, creating a new local file in the process
FtpPutFile
Stores a file on the FTP server
FtpRemoveDirectory
Removes the specified directory on the FTP server
FtpRenameFile
Renames a file stored on the FTP server
FtpSetCurrentDirectory
Changes to a different working directory on the FTP server


توابع HTTP :

Name
Description
HttpAddRequestHeaders
Adds one or more HTTP request headers to the HTTP request handle
HttpEndRequest
Ends an HTTP request
HttpOpenRequest
Opens an HTTP request handle
HttpQueryInfo
Queries for information about an HTTP request
HttpSendRequest
Sends the specified request to the HTTP server
HttpSendRequestEx
Sends the specified request to the HTTP server

منبع : dev.ir

[parsiyan_mohsen]

بررسی جزئيات توابع Dial-Up موجود در WinInet :
1 – تابع InternetAutodial : بطور اتوماتيک باعث شماره گيری اتصال پيش فرض اينترنت توسط مودم می شود . اگر اتصال با موفقيت انجام شود تابع مقدار true و در غير اينصورت false بر می گرداند .
پارامترهای ورودی تابع :
dwFlags : فلگ کنترل کننده عمليات اتصال می باشد و يکی از مقادير زير را می تواند داشته باشد :
- INTERNET_AUTODIAL_FORCE_ONLINE
- INTERNET_AUTODIAL_FORCE_UNATTENDED
dwReserved : پارامتری رزرو شده است و بايستی صفر باشد .
چگونگی declare کردن تابع :
Public Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
2 – تابع InternetAutodialHangup : باعث قطع کردن يک اتصال dial-up اتوماتيک می شود . اگر قطع اتصال با موفقيت انجام شود تابع مقدار true و در غير اينصورت false برمی گرداند . تابع دارای يک پارامتر ورودی به اسم dwReserved است که رزرو شده بود و بايستی صفر باشد .
چگونگی declare کردن تابع :
Public Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long
3 – تابع InternetDial : يک اتصال به اينترنت را با استفاده از يک ارتباط مودم مقداردهی اوليه می کند . پارامترهای ورودی آن عبارتند از :
hwndParent : هندل مربوط به پنجره parent
lpszConnectoid : نام ارتباط dial-up مورد استفاده
dwFlags : فلگ کنترل اتصال که يکی از مقادير زير را می تواند داشته باشد :
- INTERNET_AUTODIAL_FORCE_ONLINE
- INTERNET_AUTODIAL_FORCE_UNATTENDED
- INTERNET_DIAL_UNATTENDED : اتصال به اينترنت از طريق مودم بدون نمايش واسط کاربر
lpdwConnection : آدرس داده ای که شامل عدد متناظر با اتصال است .
dwReserved : پارامتری رزرو شده است و بايستی صفر باشد .
چگونگی declare کردن تابع :
Public Declare Function InternetDial Lib "wininet.dll" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwFlags As Long, lpdwConnection As Long, ByVal dwReserved As Long) As Long
4 – تابع InternetGetConnectedState : اين تابع وضعيت اتصال جاری به اينترنت را بر می گرداند . اگر اتصال برقرار باشد تابع مقدار true و در غير اينصورت false برمی گرداند .
پارامترهای ورودی تابع عبارتند از :
lpdwFlags : توصيف وضعيت اتصال . اين پارامتر يکی از مقادير زير را می تواند داشته باشد :
- INTERNET_CONNECTION_MODEM
- INTERNET_CONNECTION_LAN
- INTERNET_CONNECTION_PROXY
- INTERNET_CONNECTION_MODEM_BUSY
dwReserved : پارامتری رزرو شده است و بايستی صفر باشد .
چگونگی declare کردن تابع :
Public Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
5 – تابع InternetGoOnline : پيغامی به کاربر برای دادن مجوز برای مقداردهی اوليه اتصال به يک URL را می دهد . اگر اينکار موفقيت آميز باشد مقدار true و در غير اينصورت false برمی گرداند . پارامترهای ورودی تابع عبارتند از :
lpszURL : URL وب سايت مورد نظر برای اتصال
hwndParent : هندل پنجره parent
dwReserved : پارامتری رزرو شده است و بايستی صفر باشد .
چگونگی declare کردن تابع :
Public Declare Function InternetGoOnline Lib "wininet.dll" (ByVal lpszURL As String, ByVal hwndParent As Long, ByVal dwReserved As Long) As Long
6 – تابع InyernetHangUp : به مودم می گويد که اتصال به اينترنت را قطع کند . پارامترهای اين تابع عبارتند از :
dwConnection : شماره مربوط به اتصالی که می خواهيم آنرا قطع کنيم .
dwReserved : پارامتری رزرو شده است و بايستی صفر باشد .
چگونگی declare کردن تابع :
Public Declare Function InternetHangUp Lib "wininet.dll" (ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
7 – تابع InternetSetDialState : تنظيم نمودن وضعيت شماره گيری مودم . اگر تنظيم با موفقيت انجام شود تابع true و در غيراينصورت false برمی گرداند . پارامترهای ورودی تابع عبارتند از :

lpszConnectoid : نام اتصال dial-up
dwState : وضعيت مربوط به اتصال dial-up . در حال حاضر اين پارامتر تنها مقدار INTERNET_DIALSTATE_DISCONNECTED را می تواند داشته باشد .
dwReserved : پارامتری رزرو شده است و بايستی صفر باشد .
چگونگی declare کردن تابع :
Public Declare Function InternetSetDialState Lib "wininet.dll" (ByVal lpszConnectoid As String, ByVal dwState As Long, ByVal dwReserved As Long) As Long

[parsiyan_mohsen]

بررسی فلگهای مورد استفاده در توابع dial-up :
1 – فلگهای تابع InternetDial :
Public Const INTERNET_DIAL_UNATTENDED = &H8000& '0x8000
Public Const INTERENT_GOONLINE_REFRESH = &H1 '0x00000001
Public Const INTERENT_GOONLINE_MASK = &H1 '0x00000001
2 – فلگهای تابع InternetAutoDial :
Public Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Public Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2
Public Const INTERNET_AUTODIAL_FAILIFSECURITYCHECK = 4

3 – فلگهای تابع InternetGetConnectedState :
Public Const INTERNET_CONNECTION_MODEM = 1
Public Const INTERNET_CONNECTION_LAN = 2
Public Const INTERNET_CONNECTION_PROXY = 4
Public Const INTERNET_CONNECTION_MODEM_BUSY = 8
4 - فلگهای مربوط به dial handler اختصاصی :
Public Const INTERNET_CUSTOMDIAL_CONNECT = 0
Public Const INTERNET_CUSTOMDIAL_UNATTENDED = 1
Public Const INTERNET_CUSTOMDIAL_DISCONNECT = 2
5 – فلگهای عملياتی پشتيبانی شده برای dial handler اختصاصی :
Public Const INTERNET_CUSTOMDIAL_SAFE_FOR_UNATTENDED = 1
Public Const INTERNET_CUSTOMDIAL_WILL_SUPPLY_STATE = 2
Public Const INTERNET_CUSTOMDIAL_CAN_HANGUP = 4
6 - وضعيتهای مربوط به InternetSetDialState :
Public Const INTERNET_DIALSTATE_DISCONNECTED = 1


در اين بخش که آخرين بخش از مباحث WinInet API است برنامه ای نمونه برای کار با توابع مودمی اين کتابخانه ارائه خواهيم داد :
برای نوشتن برنامه ای که بتوان از طريق آن با استفاده از مودم به اينترنت متصل شد بصورت زير عمل می کنيم :
در ابتدا بايستی تابع InternetDial را Declare کنيم :
Private Declare Function InternetDial Lib "wininet.dll" Alias "InternetDialA" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwFlags As Long, lpdwConnection As Long, ByVal dwReserved As Long) As Long
سپس وضعيت شماره گيری را در متغيری به اسم lOption قرار می دهيم . اين متغير می تواند مقادير زير را داشته باشد :
- DF_FORCE_ONLINE
- DF_FORCE_UNATTENDED
- DF_DIAL_FORCE_PROMPT
- DF_DIAL_UNATTENDED
حال نام اتصالی را که می خواهيم از آن استفاده شود در متغيری به اسم ConnectionName قرار می دهيم .
همچنين دو متغير به اسم ConnectionID و RetVal را از نوع long تعريف می کنيم .
حال تابع InternetDial را بصورت زير صدا می کنيم :
RetVal = InternetDial(Me.hwnd, ConnectionName, lOption, ConnectionID, 0)
اگر RetVal مخالف صفر باشد عمل Dial بدرستی انجام شده است .
برای قطع اتصال فوق بايستی از تابع InternetHangUp استفاده کنيم . برای اينکار ابتدا تابع فوق را Declare می کنيم :
Private Declare Function InternetHangUp Lib "wininet.dll" (ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
سپس اين تابع را بصورت زير فراخوانی می کنيم :
RetVal = InternetHangUp(ConnectionID, 0)
برای اينکه مودم را مجبور کنيم تا بطور اتوماتيک از اتصال پيش فرض سيستم برای شماره گيری استفاده کند از تابع InternetAutodial استفاده می کنيم .
برای اينکار ابتدا تابع را Declare می کنيم :
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal hwndParent As Long) As Long
سپس تابع را بصورت زير فراخوانی می کنيم :
RetVal = InternetAutodial(ADF_FORCE_UNATTENDED, Me.hwnd)
اگر RetVal مخالف صفر باشد عمل AutoDial بدرستی انجام شده است .
برای قطع اتصالی که توسط AutoDial ايجاد شده از تابع InternetAutodialHangup استفاده می کنيم . ابتدا اين تابع را Declare می کنيم :
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long
فراخوانی اين تابع بصورت زير است :
Call InternetAutodialHangup(0)
برای اينکه بفهيم آيا اتصال به اينترنت وجود دارد يا نه از تابع InternetGetConnectedStateEx استفاده می کنيم . برای اينکار ابتدا تابع را Declare می کنيم :
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" (lpdwFlags As Long, lpszConnectionName As Long, dwNameLen As Long, ByVal dwReserved As Long) As Long
سپس تابع را بصورت زير فراخوانی می کنيم :
strConnectionName = Space(256)
lNameLen = 256
lPtr = StrPtr(strConnectionName)
lNameLenPtr = VarPtr(lNameLen)
RetVal = InternetGetConnectedStateEx(lConnectionFlags, ByVal lPtr, ByVal lNameLen, 0)
که strConnectionName از نوع String و بقيه متغيرها از نوع Long هستند .
اگر RetVal مخالف صفر باشد اتصال برقرار است .
ثابتهايی که در کدهای فوق استفاده شده عبارتند از :
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1&
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2&
Private Const INTERNET_AUTODIAL_FAILIFSECURITYCHECK = 4&
Private Const INTERNET_DIAL_FORCE_PROMPT = &H2000
Private Const INTERNET_DIAL_SHOW_OFFLINE = &H4000
Private Const INTERNET_DIAL_UNATTENDED = &H8000

[parsiyan_mohsen]

TAPI چيست ؟

TAPI يا Telephony API يک کتابخانه استاندارد برای کار با مودم و نوشتن برنامه های تلفنی می باشد . برای نمونه می توان از برنامه های Phone Dialer ( شماره گير تلفن ) ، برنامه شبکه سازی تلفنی ( Dialup Networking ) ، برنامه تشخيص پالس مودم برای ضبط اطلاعات وارد شده از طرف کاربران و کاربردهای ديگر در اين زمينه نام برد . اين کتابخانه به شما کمک کمک می کند تا بدون درگير شدن با برنامه نويسی سخت افزار مودم و درايور آن بطور مستقيم بتوانيد برنامه های کاربردیي در اين زمينه بنويسيد .
مروری بر Microsoft Telephony :

Telephony امکان مجتمع سازی کامپيوترها با دستگاههای ارتباطی و شبکه ها را فراهم نموده است . معمولاً دستگاه ارتباطی يک مودم و خط ارتباطی نيز شبکه PSTN ( شبکه عمومی تلفن سوئيچينگ ) می باشد . برخی از کاربردهای Telephony عبارتند از :

۱ - کنفرانسهای مالتی مديا بصورت Multicast
۲ - VoIP
۳ - مرکز پاسخ گويي اتوماتيک
۴ - تماس تلفنی از طريق کامپيوتر روی شبکه PSTN

دياگرام زير معماری Microsoft Telephony را نشان می دهد :
برنامه های TAPI :

برای نوشتن برنامه های کاربردی با استفاده از TAPI بايستی ابتدا در مورد سطح سرويسی که می خواهيم ارائه دهيم تصميم گيری کنيم . برای مثال برای نوشتن يک برنامه شماره گير تلفن نياز به استفاده کامل از TAPI نيست و می توان از قابليتهای خود ويندوز در اين زمينه استفاده کرد ( Assisted Telephony ) . در بخشهای بعدی در مورد سطوح مختلف سرويس در TAPI بيشتر صحبت خواهم کرد .
دومين مطلبی که بايد مورد توجه قرار داد اينست که می خواهيم از TAPI 2.x استفاده کنيم يا از TAPI 3.x . تفاوت ايندو آنست که TAPI ورژن ۲ يک API برمبنای C است در حاليکه ورژن ۳ آن بر مبنای تکنولوژی COM می باشد . در بخشهای بعدی مطالب بيشتری در مورد تفاوتهای اين دو نسخه بيان خواهم کرد .
بخشهای اصلی يک برنامه کامل TAPI عبارتند از :

۱ - TAPI Initialization : شامل load کردن TAPI dll ، اتصال به TAPI Server ، مذاکره در مورد ورژن TAPI و برپاسازی سيستم اطلاع رسانی event می باشد .

۲ - Session Control : مقداردهی اوليه ، دريافت و کنترل تماسها

۳ - Device Control : دريافت و تنظيم اطلاعات دستگاه

۴ - Media Control : تشخيص و يا توليد تونها و ارقام ، کنترل stream

۵ - TAPI Shutdown : آزاد سازی منابع
مقداردهی اوليه TAPI :

عملکرد درست اجزای TAPI نياز به برپاسازی محيط ارتباطی روی کامپيوتر مورد نظر دارد . مراحل اين امر عبارتند از :

۱ - نصب TAPI : زمانيکه سخت افزار و يا نرم افزار برای اولين بار به کامپيوتر اضافه می شود انجام می گيرد . جزئيات کار به سيستم عامل و نرم افزار بستگی دارد .

۲ - مقداردهی ابتدائی : ساخت اشيا و مسيرهای ارتباطی

۳ - مذاکره در مورد ورژن TAPI : برای اطمينان از اينکه اجزای TAPI قادر به تبادل داده ها باشند .

۴ - استخراج اطلاعات منابع : بدست آوردن اطلاعاتی در مورد دستگاهی که می توان از آن در برنامه TAPI مورد نظرمان استفاده نمود .

۵ - Event notification : برپاسازی سيستم اطلاع رسانی event
مقداردهی اوليه TAPI در ويژوال بيسيک :

از منوی Project گزينه References را انتخاب کرده و از ليست مربوطه مورد Microsoft TAPI 3.0 Type Library را انتخاب کنيد .
حال وارد بخش کد نويسی فرمتان شويد و متغير objTAPI را بصورت زير تعريف کنيد :


Dim objTapi As TAPI

سپس در بخش مربوط به Form Load شی objTAPI را بصورت زير ايجاد می کنيم :


Set objTapi = New TAPI

همانطور که در بخشهای قبلی گفته شد ، قبل از فراخوانی هر تابع TAPI ابتدا بايستی آنرا مقداردهی اوليه کنيم . برای مقداردهی اوليه کردن شی TAPI عبارت زير را بنويسيد :


Call objTapi.Initialize

انتخاب يک آدرس :
کد زير نشان می دهد که چگونه می توان با استفاده از شی TAPI در ويژوال بيسيک منابع تلفنی در دسترس را برای يک آدرس که بتواند يک مجموعه مشخص از نيازها را مديريت کند ، بررسی کرد .
توجه داشته باشيد که قبل از انجام اين کار بايستی عمل مقداردهی اوليه TAPI را که در بخش قبل ررسی شد ، انجام دهيد .

نکته : در کد زير عمل error checking انجام نگرفته است و برای استفاده از کد زير در برنامه های واقعی بايستی بخش بررسی خطا را به آن اضافه کنيد .
۱ - تعريف يک شی آدرس و يک شی مجموعه آدرس :


Dim gobjAddress As ITAddress
Dim objCollAddresses As ITCollection

۲ - تنظيم شی objCollAddress بعنوان يک مجموعه آدرس از شی objTapi :


Set objCollAddresses = objTapi.Addresses

۳ - پيدا کردن آدرسی که بتواند از واسط مورد نظر ما پشتيبانی کند :


bFound = False
For indexAddr = 1 To objCollAddresses.Count
Set objCrtAddress = objCollAddresses.Item(indexAddr)x
Set objMediaSupport = objCrtAddress
Set objAddressCapabilities = objCrtAddress

If objMediaSupport.QueryMediaType( nSelectedType ) x
bFound = True
End If

Set objAddressCapabilities = Nothing
Set objMediaSupport = Nothing
Set objCrtAddress = Nothing

If bFound = True Then Exit For
Next indexAddr


در صورتيکه آدرس مورد نظزر پيدا شود برنامه از حلقه خارج شده و gobjAddress يک آدرس قابل استفاده خواهد بود :


Set gobjAddress = objcollAddresses.Item(indexAddr)x

انجام Event Handling در TAPI :

کد زير شامل يک event handler ساده برای TAPI ، رجيستر کردن واسط event ، تنظيم فيلتر event و رجيستر کردن تمام فراخوانيهای دادن اخطار است . هدف اصلی از اين کد اينست که مطمئن شويم بخشی از TAPI که event ها را دريافت می کند پردازشی را قبل از انتقال به بخشهای ديگر انجام دهد .

تعاريفها :


Dim WithEvents gobjTapiWithEvents As TAPI
Attribute gobjTapiWithEvents.VB_VarHelpID = -1
Dim glRegistrationToken As Long


Const TAPI3_CALL_EVENTS =TE_CALLMEDIA Or
TE_CALLNOTIFICATION Or TE_CALLSTATE


تنظيم eventfilter بصورتيکه تمام event های تعريف شده برای TAPI را بپذيرد :


objTapi.EventFilter = TAPI3_CALL_EVENTS

رجيستر کردن event ها :


Set gobjTapiWithEvents = objTapi
Dim fOwner As Boolean, fMonitor As Boolean
Dim lMediaTypes As Long, lCallbackInstance As Long

fOwner = True
fOwner = True
fMonitor = False
lMediaTypes = TAPIMEDIATYPE_AUDIO
lCallbackInstance = 1

glRegistrationToken = gobjTapi.RegisterCallNotifications(gobjAddress,fMo nitor,
fOwner,lMediaTypes,lCallbackInstance)x

انتخاب يک ترمينال :

+ قبل از اينکه يک ترمينال را برای برقراری ارتباط انتخاب کنيد بايستی TAPI Initialization و عمل انتخاب آدرس را انجام داده باشيد .

ابتدا يک متغير از نوع ITBasicCallControl ( واسط کنترل تماس ) تعريف می کنيم :


Dim objCallControl As ITBasicCallControl
Set objCallControl = gobjReceivedCallInfo

سپس يک متغير از نوع ITTerminalSupport ( کوئری از شی آدرس ) تعريف می کنيم :


Dim objTerminalSupport As ITTerminalSupport
Set objTerminalSupport = gobjAddress

سپس متغير ترمينال را تعريف کرده و توسط شی objTerminalSupport يک ترمينال را برای آن استخراج می کنيم :


Dim objTerminal As ITTerminal
Set objTerminal = objTerminalSupport.GetDefaultStaticTerminal(lMedia Type, dir)x

در اينجا ديگر نيازی به شی objTerminalSupport نيست بنابراين آنرا آزاد می کنيم :


Set objTerminalSupport = Nothing

سپس نياز به تعريف شی objStreamControl برای کنترل ترمينال است :


Dim objStreamControl As ITStreamControl
Set objStreamControl = objCallControl

در صورتيکه اين شی ايجاد شود ، به ازای استريم های موجود در ITCollection امکان ايجاد ترمينال در يک حلقه for بررسی می شود و ترمينال مناسب انتخاب می گردد :


If Not (objStreamControl Is Nothing) Then
Dim objITCollStreams As ITCollection

Set objITCollStreams = objStreamControl.Streams

Dim nIndex As Long, objCrtStream As ITStream

For nIndex = 1 To objITCollStreams.Count
Set objCrtStream = objITCollStreams.Item(nIndex)x
If objCrtStream.MediaType = lMediaType Then
If objCrtStream.Direction = dir Then
Call objCrtStream.SelectTerminal(objTerminal)x
End If
End If
Set objCrtStream = Nothing
Next nIndex

Set objITCollStreams = Nothing
Set objStreamControl = Nothing
End If


ايجاد يک تماس ( Make a Call ) :
+ قبل از اين بخش بايستی مراحل TAPI Initialization و عمل انتخاب آدرس انجام شده باشد .
اين بخش برای ايجاد يک شی تماس ، بررسی و مشخص کردن استريمی که با اين تماس در ارتباط است ، انتخاب و ايجاد ترمينالهای مناسب و کامل کردن ارتباط استفاده می شود .
قبل TAPI Initialization و عمل انتخاب آدرس و انتخاب ترمينال انجام شده باشد .
در ابتدا با استفاده از متد CreateCall يک شی تماس ساخته می شود :


Set gobjCall = gobjOrigAddress.CreateCall(strDestAddress, nSelectedType,lMediaTypes)x

سپس در اينجا بايستی کدی که در بخش اول اين درس برای انتخاب ترمينال نوشته شد آورده شود :


}
Select Terminal Code
{

سپس بايستی دستور Connect اجرا شود :


gobjCall.Connect (False)x

False بدين معناست که ارتباط بصورت آسنکرون برقرار می شود .
دريافت يک تماس :

کد زير برای يافتن و يا ايجاد يک ترمينال مناسب برای دريافت يک تماس بکار می رود . بايستی توجه داشته باشيد که قبل از اجرای کد زير بايستی مراحل مقداردهی اوليه ، انتخاب يک آدرس و رجيسر کردن event ها را انجام دهيد . همچنين در کد زير بايستی مرحله انتخاب ترمينال را نيز انجام دهيد . توجه داشته باشيد که در کد زير متغير pEvent يک اشاره گر برای واسط ITCallNotificationEvent است که توسط TAPI به event Handler داده می شود :


If TapiEvent = TE_CALLNOTIFICATION Then
Dim objCallNotificationEvent As ITCallNotificationEvent
Set objCallNotificationEvent = pEvent
Dim gobjReceivedCallInfo As ITCallInfo
Set gobjReceivedCallInfo = objCallNotificationEvent.Call
Dim objCallControl As ITBasicCallControl
Set objCallControl = gobjReceivedCallInfo
objCallControl.Answer
End If

[parsiyan_mohsen]

گرفتن اطلاعات ورودی از کيبرد - ۱



Direct Input 8 همانطور که از نامش مشخص است به شما اجازه می دهد که بتوانيد برنامه هايي بنويسيد که توسط هر نوع دستگاه ورودی کنترل شود .
Direct Input 8 دارای چندين مزيت نسبت به استفاده از کنترلهای ورودی خود ويژوال بيسيک دارد – کنترلهايي مثل Form_KeyUp, Form_KeyDown, Form_MouseMove - و همچنين قابليت کنترل بيشتری نسبت به توابع استاندارد Win32 از قبيل GetCursorPos, GetKeyState دارد .
Direct Input 8 سريعتر ، کاراتر و قدرتمند تر بوده و برای ساخت بازيها طراحی شده بنابراين باعث کندی برنامه ها نخواهد شد .

چگونگی کار با Direct Input 8 برای گرفتن ورودی از کيبرد

دو روش برای استفاده از کيبرد در DirectX8 وجود دارد : روش polling و روش event-based که هر دو دارای مزايا و معايبی هستند .
بطور کلی در اغلب طراحيها از روش event-based استفاده می شود زيرا کار با آن راحت تر اسن . در اين روش هر پيغام فرستاده شده ازطرف دستگاه ورودی log می شود و برنامه نيازی به هيچگونه پردازشی بمنظور منتظر ماندن برای يک پيغام از طرف ورودی ندارد ، بنابر اين کاراتر است . در روش polling کنترل کمی دقيقتر و راحتر است .
اگر در مورد برنامه نويسی بر مبنای polling و بر مبنای event اطلاعات کافی نداريد می توانيد از منابع موجود در سايتهايي چون Gamasutra (mk:@MSITStore:H:\Project.1\dev.ir.chm::/www.gamasutra.com/default.htm) و GameDev (mk:@MSITStore:H:\Project.1\dev.ir.chm::/www.gamedev.net/default.htm) استفاده کنيد .

روش Polling

مراحل اين روش عبارتند از :

1 – تعريفات Declerations : يک فرم ايجاد کرده و يک TextBox به نام txtOutput با خصوصيات Multiline ، Locked و Vertical Scroll Bar در آن قرار دهيد . کدهای زير را در بخش کدنويسی اين فرم بنويسيد :


Private Const UsePollingMethod As Boolean = True
Private Const UseEventMethod As Boolean = False
‘نکته مهم اينست که تنها يکی از دو ثابت فوق بايستی True باشد .
Private bRunning As Boolean
‘اين متغير برای polling استفاده می شود
Private DX As DirectX8
Private DI As DirectInput8
‘تعريف شی اصلی DirectX و شی DirectInput
Private DIDevice As DirectInputDevice8
Private DIState As DIKEYBOARDSTATE
‘اين دو شی برای دسترسی به دستگاه ورودی ( کيبرد ) استفاده می شوند
Private KeyState(0 To 255) As Boolean
‘آرايه ای برای تشخيص فشرده شدن کليد
Private Const BufferSize As Long = 10
‘ سايز بافر نگهدارنده event ها . در روش event-based اين مقدار برابر يک و در روش polling برابر 10 تا 20 است ( بسته به سرعت حلقه بازی )
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)x
‘ تابع Sleep برای متوقف کردن حلقه polling در صورت بالا بودن نرخ ورودی


2- مقدار دهی اوليه Initialisation : اين بخش سه مرحله دارد :
در مرحله اول اشيا و Device ها ساخته می شوند .
در مرحله دوم تنظيمات مربوط به Device انجام می شود .
در مرحله سوم به Device می گوئيم که می خواهيم شروع به استفاده از آن کنيم .

در Form_Load کدهای زير را بنويسيد :


Me.Show
Dim I As Long
Dim DevProp As DIPROPLONG
Dim DevInfo As DirectInputDeviceInstance8
Dim pBuffer(0 To BufferSize) As DIDEVICEOBJECTDATA
If UsePollingMethod And UseEventMethod Then
MsgBox "You must select only one of the constants before running"x
Unload Me
End
End If

If UsePollingMethod Then txtOutput.Text = "Using Polling Method" & vbCrLf
If UseEventMethod Then txtOutput.Text = "Using Event Based Method" & vbCrLf

‘مقداردهی اوليه روش انتخاب شده
Set DX = New DirectX8
Set DI = DX.DirectInputCreate
Set DIDevice = DI.CreateDevice("GUID_SysKeyboard")x

DIDevice.SetCommonDataFormat DIFORMAT_KEYBOARD
DIDevice.SetCooperativeLevel frmMain.hWnd, DISCL_BACKGROUND Or ISCL_NONEXCLUSIVE

‘برپاسازی بافر
DevProp.lHow = DIPH_DEVICE
DevProp.lData = BufferSize
DIDevice.SetProperty DIPROP_BUFFERSIZE, DevProp

‘ به دايرکت ايکس می گوئيم که می خواهيم از دستگاه ورودی استفاده کنيم
DIDevice.Acquire

‘استخراج اطلاعاتی در مورد دستگاه ورودی
Set DevInfo = DIDevice.GetDeviceInfo()x
txtOutput.Text = txtOutput.Text & "Product Name: " & DevInfo.GetProductName & vbCrLf
txtOutput.Text = txtOutput.Text & "Device Type: " & DevInfo.GetDevType & vbCrLf
txtOutput.Text = txtOutput.Text & "GUID: " & DevInfo.GetGuidInstance & vbCrLf


‘در صورتی که بخواهيم به برنامه خاتمه بدهيم کدهای زير را می نويسيم
DIDevice.Unacquire
Set DIDevice = Nothing
Set DI = Nothing
Set DX = Nothing
Unload Me
End


3 – گرفتن ورودی از کيبرد : در اين بخش فرض کنيد بخواهيم يک بازی را در يک حلقه Do-Loop شبيه سازی کنيم . در اين حلقه هر بار فشرده شدن کليدهای کيبرد را چک می کنيم :


If Not Err.Number Then bRunning = True

Do While bRunning

‘دريافت اطلاعات شامل خواندن وضعيت کيبرد ، خواندن اطلاعات بافر و سپس خطا
DIDevice.GetDeviceStateKeyboard DIState
DIDevice.GetDeviceData pBuffer, DIGDD_DEFAULT
If Err.Number = DI_BUFFEROVERFLOW Then
Msgbox(“BUFFER OVERFLOW (Compensating)...")x
GoTo ENDOFLOOP:
End If
‘بررسی فشرده شدن کليدها
For I = 0 To 255
If DIState.Key(I) = 128 And (Not KeyState(I) = True) Then
txtOutput.Text = txtOutput.Text & "{ DOWN } " & KeyNames(CInt(I))& vbCrLf
txtOutput.SelStart = Len(txtOutput.Text)x
KeyState(I) = True
End If
Next I

‘بررسی رها شدن کليد
For I = 0 To BufferSize
If KeyState(pBuffer(I).lOfs) = True And pBuffer(I).lData = 0 Then
KeyState(pBuffer(I).lOfs) = False
txtOutput.Text = txtOutput.Text & "{ UP } " & KeyNames(CInt(pBuffer(I).lOfs)) & vbCrLf
txtOutput.SelStart = Len(txtOutput.Text)x
End If
Next I

Sleep (50)x
DoEvents
ENDOFLOOP:
Loop

در کد فوق يک تابع KeyName وجود دارد که نام کليد فشارداده شده را بر می گرداند . بخشی از اين تابع را در زير می بينيد :



Function KeyNames(iNum As Integer) As String

Dim aKeys(0 To 255) As String

aKeys(1) = "DIK_ESCAPE"
aKeys(2) = "DIK_1 On main keyboard"x
aKeys(3) = "DIK_2 On main keyboard"x
aKeys(4) = "DIK_3 On main keyboard"x
aKeys(5) = "DIK_4 On main keyboard"x
aKeys(6) = "DIK_5 On main keyboard"x
aKeys(7) = "DIK_6 On main keyboard"x
aKeys(8) = "DIK_7 On main keyboard"x
aKeys(9) = "DIK_8 On main keyboard"x
aKeys(10) = "DIK_9 On main keyboard"x
aKeys(11) = "DIK_0 On main keyboard"x
aKeys(12) = "DIK_MINUS On main keyboard"x
aKeys(13) = "DIK_EQUALS On main keyboard"x
aKeys(14) = "DIK_BACK BACKSPACE"x
aKeys(15) = "DIK_TAB"x
aKeys(16) = "DIK_Q"x
aKeys(17) = "DIK_W"x
aKeys(18) = "DIK_E"x
aKeys(19) = "DIK_R"x
aKeys(20) = "DIK_T"x
.
.
.
KeyNames = aKeys(iNum)x

End Function

[parsiyan_mohsen]

موضوع : کنترل کيبرد با روش Event-Based

مقداردهی اوليه و مفاهيم اصلی در روش Event-Based مشابه روش Polling است و تنها بايستی ساختار بخش جمع آوری داده و حلقه پردازشی را تغيير دهيم . مراحل کار با روش Event-Based بصورت زير می باشد :

۱ - تعاريف و مقداردهی اوليه : در بخش تعاريف دو تعريف جديد بصورت زير داريم :


Dim hEvent As Long
Implements DirectXEvent8

hEvent يک پارامتر هندل برای يک می باشد .
نکته : زمانی که کليدی فشرده يا رها می شود ، DirectX اين امر با فراخوانی تابعی به اسم DirectXEvent8_DXCallback به برنامه شما اطلاع می دهد . ( اين نوع توابع را Call Back Function گويند ) . اين تابع به برنامه شما می گويد که يک رويداد اتفق افتاده است و بايستی بافرها را چک کند .

تنها تغييری که در بخش مقداردهی اوليه نياز است ، برپاسازی يک event می باشد :


If UseEventMethod Then
hEvent = DX.CreateEvent(frmMain)x
DIDevice.SetEventNotification hEvent
End If

در انتهای برنامه نيز کد زير را برای از بين بردن event اضافه کنيد :


If hEvent <> 0 Then DX.DestroyEvent hEvent


۲ - استفاده از event : برای اين بخش کدهايي را در داخل تابع DirectXEvent8_DXCallback می نويسيم :


Private Sub DirectXEvent8_DXCallback(ByVal eventid As Long)x
'متغيرهای موردنياز
Dim I As Long
Dim pBuffer(0 To BufferSize) As DIDEVICEOBJECTDATA
If eventid = hEvent Then
If DIDevice Is Nothing Then Exit Sub
'درصورت رخ دادن event داده را از کيبرد می گيريم
DIDevice.GetDeviceStateKeyboard DIState
DIDevice.GetDeviceData pBuffer, DIGDD_DEFAULT
'چک کردن تمام کليدها برای اينکه متوجه شويم چه اتفاقی افتاده است
For I = 0 To 255
'عدد ۱۲۸ نشان دهنده key_down event است .
If DIState.Key(I) = 128 Then
If pBuffer(0).lData = 128 Then
txtOutput.Text = txtOutput.Text & "{ DOWN } " & KeyNames(CInt(I)) & vbCrLf
End If
End If
'کد فوق برای بررسی فشرده شدن يک کليد بود . کد زير رها شدن کليد را بررسی می کند
If (pBuffer(0).lData = 0 And pBuffer(0).lOfs = I) Then
txtOutput.Text = txtOutput.Text & "{ UP }" & KeyNames(CInt(I)) & vbCrLf
End If

txtOutput.SelStart = Len(txtOutput.Text)x
Next I
End If
End Sub

[parsiyan_mohsen]

موضوع : کنترل ماوس با DirectX Input



برای استفاده از ماوس در برنامه های مالتی مديا و بازيها همانند کی برد می توانيم از امکانات دايرکت ايکس استفاده کنيم . روش کنترل ماوس توسط DirectX Input بسيار ساده بوده و مشابه کنترل کيبرد می باشد بنابراين درصورتی که دو درس گذشته را نخوانده اين پيشنهاد می کنم ابتدا آنها را مطالعه کنيد .

برپاسازی Device :

علاوه بر متغيرهايي که در بخش کنترل کيبرد تعريف شد بايستی متغيرهای جديد زير را نيز در ابتدای برنامه تان تعريف کنيد :


Private Const mSpeed As Single = 2
Private Const BufferSize As Long = 10
Private mPosition As Point

mSpeed مقدار سرعت حرکت کرسر ماوس را مشخص می کند .
BufferSize سايز بافر DI می باشد .
mPosition موقعيت جاری کرسر ماوس را نشان می دهد .

در مرحله بعدی بايستی مقداردهي های اوليه لازم را انجام دهيد :


Set DIDevice = DI.CreateDevice("guid_SysMouse")x
Call DIDevice.SetCommonDataFormat(DIFORMAT_MOUSE)x
Call DIDevice.SetCooperativeLevel(frmMain.hWnd, DISCL_FOREGROUND Or DISCL_EXCLUSIVE)x

تفاوت عمده کدهای فوق با کدهای مقداردهی اوليه در بخش کی برد آنست که cooperativelevel تغيير کرده است . در اينجا گفته شده که ما می خواهيم از ماوس بصورت انحصاری در برنامه استفاده کنيم . اين حالت برای برنامه های window-base مناسب نيست و بهترست از آن در بازيهايي که بصورت full screan هستند استفاده کنيد .

خواندن ورودی از ماوس :

در اين بخش می توانيد هم از روش polling و هم event-based استفاده کنيد . نکته مهمی که در اينجا وجود دارد آنست که Direct Input فقط حرکت داده شدن ماوس و کليک شدن يک دکمه را به شما اطلاع می دهد و برای تشخيص حالتهای double click و single click خودتان بايستی کد بنويسيد برای مثال اگر فاصله زمانی بين دو کليک کمتر از ۴۰ ميلی ثانيه باشد آنگاه اين يک double click بوده است .
کد زير حرکت داده شدن ماوس و کليک يکی از سه دکمه آنرا اطلاع می دهد :


Dim DevData(1 To BufferSize) As DIDEVICEOBJECTDATA
Dim nEvents As Long
Dim I As Long
nEvents = DIDevice.GetDeviceData(DevData, DIGDD_DEFAULT)x
For I = 1 To nEvents
Select Case DevData(I).lOfs
Case DIMOFS_X
mPosition.x = mPosition.x + (DevData(I).lData * mSpeed)x
If mPosition.x < 0 Then mPosition.x = 0
If mPosition.x > frmMain.ScaleWidth Then mPosition.x = frmMain.ScaleWidth
imgCursor.Top = mPosition.y
imgCursor.Left = mPosition.x
lablel(1).Caption = "Mouse Coordinates: [" & mPosition.x & ", " & mPosition.y & "]"x
Case DIMOFS_Y
mPosition.y = mPosition.y + (DevData(I).lData * mSpeed)x
If mPosition.y < 0 Then mPosition.y = 0
If mPosition.y > frmMain.ScaleHeight Then mPosition.y = frmMain.ScaleHeight
imgCursor.Top = mPosition.y
imgCursor.Left = mPosition.x
lablel(1).Caption = "Mouse Coordinates: [" & mPosition.x & ", " & mPosition.y & "]"x
Case DIMOFS_BUTTON0
label(2).Caption = "Button 0 State: " & IIf(DevData(I).lData = 0, "Up", "Down")x
Case DIMOFS_BUTTON1
label(3).Caption = "Button 1 State: " & IIf(DevData(I).lData = 0, "Up", "Down")x
Case DIMOFS_BUTTON2
label(4).Caption = "Button 2 State: " & IIf(DevData(I).lData = 0, "Up", "Down")x
Case DIMOFS_BUTTON3
label(5).Caption = "Button 3 State: " & IIf(DevData(I).lData = 0, "Up", "Down")x
End Select
Next I

برای استفاده از کد فوق در روش Polling ، بايستی آنرا در يک حلقه Do while-Loop قرار دهيد .
برای استفاده از کد فوق در روش Event-Based ، بايستی آنرا درون روتين DirectXEvent8_DXCallback قرار دهيد .

[parsiyan_mohsen]

موضوع : پخش افکتهاي صوتی در برنامه هاي مالتي مديا

در سلسله مباحث DirectXAudio شما تکنيکهاي لازم براي اضافه کردن موزيک و افکتهاي صوتي سريع و ديناميک را به بازيها و برنامه هاي مالتي مديا خواهيد آموخت . DirectXAudio جايگزيني براي بخشهاي DirectSound ، DirectSound3D و DirectMusic موجود در DirectX 7 مي باشد و داراي امکانات بهتر و سريعتری بوده و برنامه نويسي آن نيز ساده تر است .
در اولين درس از DirectXAudio چگونگي پخش افکتهاي صوتي را در برنامه هايتان خواهيد آموخت .

Initial کردن DirectSound :
DirectSound اولين مبحثي است که آنرا توضيح خواهم داد . گرچه DirectXAudio يک نام عمومي براي امکانات صوتي DirectX8 مي باشد اما بين Sound و Music تفاوت وجود دارد .
DirectSound با پخش افکتهاي صوتي ارتباط دارد . DirectSound همانند Direct3D از يکسري device سخت افزاري و نرم افزاري استفاده مي کند و افکتهاي صوتي در يکسري بافر ذخيره مي شوند .
اولين قدم براي برپاسازي DirectSound ، اضافه کردن کتابخانه DirectX8 به پروژه تان مي باشد . قدم بعدي تعريف متغيرها و object هاي موردنياز است . براي استفاده از DirectSound به متغيرهاي زير نياز داريم :


Private DX As DirectX8
Private DS As DirectSound8
Private DSBuffer As DirectSoundSecondaryBuffer8
Private DSEnum As DirectSoundEnum8
Private bLoaded As Boolean

DirectX شي کنترل کننده مرکزي است . DirectSound8 واسط مراقب براي تمام interface هاي پخش صدا است . DirectSoundSecondaryBuffer8 داده audio واقعي را براي پخش ذخيره مي کند . DirectSoundEnum8 اجازه مي دهد که اطلاعاتي را در مورد device هاي سخت افزاري/نرم افزاري استخراج کنيد و متغير bLoaded يک flag وضعيت مي باشد .
حال در برنامه بايد ليست تمام device هاي در دسترس را مشخص کنيم . ( اين امر کاملاً امکان پذير است که يک کامپيوتر بيش از يک device براي DirectSound داشته باشد ) :


Private Sub Form_Load()x
bLoaded = False
Dim I As Long
Set DX = New DirectX8
Set DSEnum = DX.GetDSEnum
For I = 1 To DSEnum.GetCount
MsgBox(DSEnum.GetDescription(I))x
Next I
End Sub

فرض کنيم که يکي از device هاي شناخته شده را انتخاب کرديم . حال بايستي device را واقعاً برپا کنيم :


If bLoaded Then
Set DSBuffer = Nothing
Set DS = Nothing
Set DX = Nothing
End If
Dim DSBDesc As DSBUFFERDESC
Set DX = New DirectX8
Set DS = DX.DirectSoundCreate(DSEnum.GetGuid(devicenumber)) x
DS.SetCooperativeLevel frmMain.hWnd, DSSCL_NORMAL

متغير devicenumber شماره device اي است که شما مي خواهيد با آن کار کنيد . DSBDesc فايل صوتي شما را توصيف مي کند .

[parsiyan_mohsen]

موضوع : پخش افکتهاي صوتی در برنامه هاي مالتي مديا

ساخت بافر و play کردن آن : تاکنون ما توانستيم DirectSound را initial کنيم . همانطور که می دانيد در تمام component های DirectX داده ها در يکسری بافر ذخيره می شوند . در مورد DirectSound نيز ما يک بافر با نام DirectSoundSecondaryBuffer8 می سازيم و داده های صوتی را در آن قرار می دهيم . برخی پارامتر ها هستند که بايد برای بافر تنظيم شوند مثل : stereo يا mono بودن بافر ، ۸ بيتی يا ۱۶ بيتی بودن بافر ، فرکانس صوتی ( 22khz ، 44khz و غيره ) . اگر اين پارامترها را مشخص نکنيم DirectSound از اطلاعات فايل صوتی استفاده می کند .
در يک کاربرد ساده ، ما تنها يک بافر صوتی از يک فايل ايجاد می کنيم اما امکان ايجاد چندين بافر بطور همزمان و نيز پخش چندين صدا بطور همزمان نيز وجود دارد :


DSBDesc.lFlags = DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_CTRLVOLUME
Set DSBuffer = DS.CreateSoundBufferFromFile(App.Path & "\Sample.wav", DSBDesc)x
MsgBox "SOUND BUFFER CREATED:"x
MsgBox "Buffer Size: " & DSBDesc.lBufferBytes & "bytes (" & Round(DSBDesc.lBufferBytes / 1024, 3) & "kb)"x
MsgBox "Buffer Channel Count:" & DSBDesc.fxFormat.nChannelsIIf(DSBDesc.fxFormat.nCh annels = 1, " (Mono)", " (Stereo)")x
MsgBox "Buffer Bits per channel: " & DSBDesc.fxFormat.nBitsPerSample & " bits"x

در بالا يک بافر صوتی ايجاد شده و اطلاعات صدا از فايل به بافر load شده است .
حال بايستی داده صوتی موجود در بافر را play کنيم :
دستور لازم برای Play کردن بافر بصورت loop :


DSBuffer.Play DSBPLAY_LOOPING

دستور لازم برای Play کردن بافر بدون loop :


DSBuffer.Play DSBPLAY_DEFAULT

دستورات لازم برای Stop کردن بافر :


DSBuffer.Stop
DSBuffer.SetCurrentPosition 0

دستور لازم برای Pause کردن بافر :


DSBuffer.Stop

تنظيم خصوصيات بافر : سه خصوصيت وجود دارد که در مورد بافر تنظيم می شود pannig ، volume و frequency
محدوده مقادير pannig بين اعداد زير است :
DSBPAN_LEFT = -10,000
DSBPAN_CENTER = 0
DSBPAN_RIGHT = 10,000
توسط متد SetPan می توان pannig بافر را تنظيم کرد :


DSBuffer.SetPan yourValue

DirectSound صدا را تقويت نمی کند بلکه آنرا تضعيف می نمايد بنابراين ماکزيمم volume عبارت است از volume ای که فايل صوتی با آن ضبط شده است . بعبارت ديگر محدود مقادير volume بين اعداد زير است :
DSBVOLUME_MAX = 0
DSBVOLUME_MIN = -10000
توسط متد SetVolume می توان volume بافر را تنظيم کرد :


DSBuffer.SetVolume yourValue

محدود فرکانسی DirectSound عبارت است از :
DSBFREQUENCY_MIN = 100 (hz)x
DSBFREQUENCY_MAX = 100000 (hz) = 100khz x
توسط متد SetFrequency می توان فرکانس بافر را تنظيم کرد :


DSBuffer.SetFrequency yourValue

[parsiyan_mohsen]

موضوع : پخش موزيک توسط DirectMusic



در اولين درس از آموزش DirectXAudio با چگونگي پخش افکتهاي صوتي آشنا شديد . اکنون اين توانايي را داريد که يک engine ساده صوتي بنويسيد . در اين بخش مباني پخش موزيک را فرا خواهيد گرفت . پس از اين درس شما مي توانيد يک ماژوال براي پخش موزيکهاي پس زمينه و افکتهاي صوتي براي برنامه هايتان ايجاد کنيد .

Initil کردن DirectMusic8 :

قبل از هر کار بايستي ماژول DirectMusic8 را مقداردهي اوليه کنيد . اينکار بصورت زير انجام مي شود :


Option ExplicitImplements DirectXEvent8
Private oDX As DirectX8
Private oDMPerf As DirectMusicPerformance8
Private oDMLoader As DirectMusicLoader8
Private oDMSeg As DirectMusicSegment8

Dim dmParams As DMUS_AUDIOPARAMS
Set oDX = New DirectX8
Set oDMPerf = oDX.DirectMusicPerformanceCreate
Set oDMLoader = oDX.DirectMusicLoaderCreate
oDMPerf.InitAudio frmMain.hWnd, DMUS_AUDIOF_ALL, dmParams, Nothing, DMUS_APATH_DYNAMIC_STEREO, 128
oDMPerf.SetMasterAutoDownload True

شي DirectMusicLoader8 کمک مي کند تا موزيک درون بافر load شود .
شي DirectMusicSegment8 مموزيکي را که بايد پخش شود ذخيره مي کند .
کد فوق کافي است يکبار زمانيکه برنامه آغاز مي شود ، اجرا گردد .
اکنون ما يک واسط مقدار دهي شده از DirectMusic داريم اما قبل از اينکه موزيک را Load کرده و پخش کنيم چگونگي terminate کردن DirectMusic را در زير مي بينيد :


If ObjPtr(oDMSeg)Then Set oDMSeg = Nothing
If ObjPtr(oDMLoader)Then Set oDMLoader = Nothing
If Not (oDMPerf Is Nothing) Then
oDMPerf.CloseDown
Set oDMPerf = Nothing
End If
If ObjPtr(oDX) Then Set oDX = Nothing


پيغامها :

در برخي از component هاي DirectX8 مثل Input , Sound , Music و Play برنامه شما بايستي يک سيستم messaging را برپا کند تا DirectX زمان وقوع برخي رخدادهاي خاص را بشما گزارش دهد . اين مطلب بخصوص زمانيکه يک موزيک را پخش مي کنيد مفيد است براي مثال مي تواند زمان خاتمه يافتن موزيک را به شما اطلاع دهد و آنگاه شما مي توانيد قطعه موزيک بعدي را پخش کنيد .
پيغامها توسط يک سيستم callback انجام مي شوند . کد زير را در تابع InitDMusic تان پس از initial کردن DirectMusic8 قرار دهيد :


oDMPerf.AddNotificationType DMUS_NOTIFY_ON_SEGMENT
hEvent = oDX.CreateEvent(Me)x
oDMPerf.SetNotificationHandle hEvent

اولين سطر به DirectMusic مي گويد چه نوع پيغامهايي را مي خواهيد به برنامه تان بفرستد . چندين نوع پيغام وجود دارد :
DMUS_NOTIFY_ON_SEGMENT = اطلاعات موزيک فعلي ( شروع پخش ، پايان پخش و غيره )
DMUS_NOTIFY_ON_CHORD = اطلاعات تغيير chord موزيک
DMUS_NOTIFY_ON_COMMAND = زمانيکه يک event فرماني صدا زده شود .
DMUS_NOTIFY_ON_MEASUREANDBEAT = اطلاعات beat/measure مربوط به موزيک فعلي
DMUS_NOTIFY_ON_PERFORMANCE = که event مربوط به سطح performance می باشد .
DMUS_NOTIFY_ON_RECOMPOSE = که recomposition event می باشد .
آخرين بخش از پيغام دهي ، تابع اصلي آن مي باشد . همانطور که در بخش Initial کردن DirectMusic ديديد يک توصيف بصورت Implements DirectXEvent8 داشتيم . بخش اصلي تابع callback مربوط به DirectXEvent8 ، شامل يک select case است که بين پيغامهاي مختلف سوئيچ می کند :


Private Sub DirectXEvent8_DXCallback(ByVal eventid As Long)x
If eventid = hEvent Then
Dim dmMSG As DMUS_NOTIFICATION_PMSG
If Not oDMPerf.GetNotificationPMSG(dmMSG) Then
Else
Select Case dmMSG.lNotificationOption
Case DMUS_NOTIFICATION_SEGABORT
Case DMUS_NOTIFICATION_SEGALMOSTEND
Case DMUS_NOTIFICATION_SEGEND
Case DMUS_NOTIFICATION_SEGLOOP
Case DMUS_NOTIFICATION_SEGSTART
Case Else
End Select
End If
End If
End Sub


پخش موزيک / متوقف کردن موزيک :

براي پخش يک موزيک ابتدا بايستي آنرا load کنيد . اينکار توسط کد زير انجام مي شود :


oDMLoader.SetSearchDirectory App.Path & "\"x
Set oDMSeg = oDMLoader.LoadSegment(App.Path & FILENAME)oDMSeg.SetStandardMidiFile

DirectMusic تنها چهار نوع فرمت صوتي را مي پذيرد : WAV ، MID ، RMI و SEG .
براي پخش فايلهاي MP3 بايستي از DirectXShow استفاده کنيد که آنرا در درسهاي بعدي خواهيد ديد .
اکنون که داده هاي فايل صوتي درون بافر load شد مي توانيد آنرا پخش کنيد :


oDMSeg.SetRepeats 0
oDMPerf.PlaySegmentEx oDMSeg, DMUS_SEGF_DEFAULT, 0

تعداد پخش شدن فايل را با متد SetRepets تنظيم کنيد . اگر اين مقدار صفر باشد ، آهنگ تنها يکبار پخش مي شود و اگر 1- باشد بطور ممتد پخش خواهد شد .
براي متوقف کردن موزيک از کد زير استفاده کنيد :


oDMPerf.StopEx oDMSeg, 0, DMUS_SEGF_DEFAULT

براي تنظيم ميزان صدا از متد SetMasterVolume استقاده کنيد :


oDMPerf.SetMasterVolume yourvalue

رنج صدا بين 20+ دسی بل تا 200- دسي بل است .
براي تنظيم Tempo از متد SetMasterTempo استفاده کنيد :


oDMPerf.SetMasterTempo yourvalue/ 100

بطور نرمال tempo برابر 1 مي باشد . عدد 2 سرعت را دو برابر مي کند و عدد 0 موزيک را قطع مي کند .

[parsiyan_mohsen]

موضوع : ايجاد صدای سه بعدی توسط DirectSound3D



تاکنون با چگونگي پخش افکتهاي صوتي و موسيقي پس زمينه توسط DirectXAudiuo آشنا شديد . اين مطالب براي کاربردهاي ساده مناسبند اما اينکه فقط ما صداي استريو داشته باشيم کافي نيست و در کاربردهاب حرفه اي بايستي از صداهاي کاملاً سه بعدي استفاده کنيم .
با استفاده از افکتهاي صوتي سه بعدي مي توانيم صدا را در تمام جهتها براي کاربر شبيه سازي کنيم اما با همه مزاياي صداي سه بعدي ، دو اشکال براي آن وجود دارد : اول اينکه پخش صداي سه بعدي پيچيده تر از پخش صداي عادي است و تنها کارت هاي سخت افزاري جديد بطور کاملاً واقعي از آن پشتيباني مي کنند و دوم اينکه صداي سه بعدي با 4 بلندگو يا بيشتر حاصل مي شود – کيفيت حالت 2 بلندگو بد نيست اما در مقايسه با حالت 4 بلندگو ، بسيار کيفيت صداي سه بعدي پايين است .

برپاسازي DirectSound3D

برپاسازي صداي سه بعدي چندان پيچيده نيست اما هر بافر صوتي که براي يک صداي سه بعدي مي سازيد ، يک overhead را به سيستم تان اضافه مي کند . همچنين برخي درايورها هستند که تنها اجازه ايجاد تعداد محدودي بافر سه بعدي را در يک لحظه مي دهند و نيز اغلب درايورها تعداد بافرهاي سه بعدي که مي توان در يک لحظه پخش کرد را محدود مي کنند ( معمولاً 8 تا 16 بافر ) .
اولين قدم در استفاده از صداي سه بعدي تعريف متغيرها و اشيا زير است :


Dim DSBuffer As DirectSoundSecondaryBuffer8
Dim DSBuffer3D As DirectSound3DBuffer8
Dim DSBListener As DirectSound3DListener8

تنها دو شي آخر براي شما جديد هستند . شي DirectSound3dBuffer8 يک ارائه سه بعدي از بافرهاي عادي است . ما همچنان از DirectSoundSecondaryBuffer8 براي نگهداري داده صوتي استفاده مي کنيم و از DirectSound3Dbuffer8 براي نگهداري پارامترهاي سه بعدي و تنظيمات سه بعدي استفاده مي کنيم . شي DirectSound3Dlistener8 نيز يک listener است و براي تنظيم کردن سرعت و جهت صدا و برخي پارامترهاي ديگر استفاده مي شود .
مرحله دوم ، ساخت بافر صوتي است . اين کار در دو بخش انجام مي شود . اول ما يک بافر صوتي نرمال مي سازيم و سپس يک واسط بافر صوتي سه بعدي را از آن بدست مي آوريم :


If Not (DSBuffer Is Nothing) Then DSBuffer.Stop
Set DSBuffer = Nothing
DSBDesc.lFlags = DSBCAPS_CTRL3D Or DSBCAPS_CTRLVOLUME
Set DSBuffer = DS.CreateSoundBufferFromFile(App.Path & "\blip.wav", DSBDesc)x
If DSBDesc.fxFormat.nChannels > 1 Then
MsgBox "You can only use mono (1 channel) sounds with DirectSound3D"x
End If
If optLow.Value Then DSBDesc.guid3DAlgorithm = GUID_DS3DALG_NO_VIRTUALIZATION
If optMedium.Value Then DSBDesc.guid3DAlgorithm = GUID_DS3DALG_HRTF_LIGHT
If optHigh.Value Then DSBDesc.guid3DAlgorithm = GUID_DS3DALG_HRTF_FULL
Set DSBuffer = DS.CreateSoundBufferFromFile(App.Path & "\blip.wav", DSBDesc)x
Set DSBuffer3D = DSBuffer.GetDirectSound3DBuffer()x

سه نکته است که بايد به آن دقت شود :
1 – اضافه کردن DSBCAPS_CTRL3D بسيار مهم است . شما اگر اين پارامتر را بکار نبريد ، قادر نخواهيد بود که واسط سه بعدي را بدست آوريد .
2 – ما بايستي تنها از افکتهاي صوتي Mono ( تک کاناله ) استفاده کنيم زيرا افکت صوتي استريو در صداي سه بعدي معنا ندارد زيرا صدا از يک نقطه در فضاي سه بعدي مي آيد .
3 – سطح الگوريتم سه بعدي – که در پارامتر DSBDesc.guid3Dalgorhthm آمده . حالت NO VIRTULIZATION تنها از CPU استفاده مي کند و روي تمام سيستم ها کار مي کند اما افکتها مينيمم هستند . حالت HRTF LIGHT هم از CPU و هم سخت افزار کارت صوتي استفاده مي کند و کيفيت بهتري را نسبت به خالت اول ارائه مي دهد . حالت HRTF FULL بهترين حالت است اما در صورتي درست کار مي کند که يک سخت افزار سه بعدي داشته باشيد .
آخرين پارامتري که بايد تنظيم کنيم شي listener است :


DSBDesc_2.lFlags = DSBCAPS_CTRL3D Or DSBCAPS_PRIMARYBUFFER
Set DSBPrimary = DS.CreatePrimarySoundBuffer(DSBDesc_2) x
Set DSBListener = DSBPrimary.GetDirectSound3Dlistener
DSBListener.SetOrientation 0#, 0#, 1#, 0#, 1#, 0#, DS3D_IMMEDIATE

تا اينجا صداي سه بعدي ما آماده است و مي توانيم برخي پخش بافر را مشابه درسهاي قبلي شروع کنيد .
پارامترهاي اختياري :

چند پارامتر وجود دارد که مي توان آنها را تغيير داد :
1 – Volume : عدد 0 بيشترين ميزان صدا و عدد 3000 - کمترين ميزان صدا را دارد :


If DSBuffer Is Nothing Then Exit Sub
DSBuffer.SetVolume scrlVolume.Value

2 – Position : تنظيم محل listener :


DSBuffer3D.SetPosition Src_X, 0, Src_Y, DS3D_IMMEDIATE
DSBListener.SetPosition Src_X, 0, Src_Y, DS3D_IMMEDIATE

3 – Velocity : تنظيم سرعت و جهت منبع صدا :


DSBuffer3D.SetVelocity X, Y, Z, DS3D_IMMEDIATE
DSBListener.SetVelocity X, Y, Z, DS3D_IMMEDIATE

4 – Dppler Effect : انحراف صدا از مسيري که مي پيمايد انحراف سرعت حرکت صدا :


DSBListener.SetDopplerFactor CSng(scrlDoppler.Value), DS3D_IMMEDIATE

5 – Rolloff Effect : rolloff چگونگي تضعيف صدا با تغيير فاصله است .


DSBListener.SetRolloffFactor CSng(scrlRolloff.Value), DS3D_IMMEDIATE

6 – Distance : ماکزيمم فاصله اي که يک صدا مي تواند شنيده شود :


DSBuffer3D.SetMaxDistance 250, DS3D_IMMEDIATE
DSBuffer3D.SetMinDistance 0.01, DS3D_IMMEDIATE

[parsiyan_mohsen]

رجيستري چيست ؟
سيستم عامل ويندوز تنظيمات سخت افزاري و نرم افزاري خود را بطور مرکزي در يک بانک اطلاعاتي با ساختار سلسله مراتبي ذخيره مي کند که رجيستري نام دارد . رجيستري جايگزيني براي بسياري از فايلهاي پيکربندي INI ، SYS و COM است که در نسخه هاي اوليه ويندوز موجود بود . رجيستري ، سيستم عامل را با مهيا کردن اطلاعات موردنيز براي اجراي برنامه ها و load شدن component ها ، کنترل مي کند .
رجيستري شامل انواع مختلفي از اطلاعات مي باشد مثل :
- اطلاعات سخت افزارهاي نصب شده روي سيستم
- اطلاعات درايورهاي نصب شده روي سيستم
- اطلاعات برنامه هاي نصب شده روي سيستم
- اطلاعات پروتکلهاي شبکه اي مورد استفاده در سيستم
ساختار رجيستري شامل چندين مجموعه رکورد است که داده هاي اين رکوردها توسط بسياري از برنامه ها و اجزاي سيستم عامل خوانده و يا نوشته مي شود .
اجزاي رجيستري
اجزاي تشکيل دهنده رجيستري عبارتند از :
1 – subtree : Subtree ها همانند folder هاي موجود در ريشه يک درايو هارد هستند . رجستری ويندوز داراي پنج subtree مي باشد :
- HKEY_LOCAL_MACHINE : شامل تمام داده هاي پيکربندي براي کامپيوتر مي باشد و شامل 5 key است :Hardware ، SAM ، Security ، Software و System
- HKEY_USERS : شامل داده هاي مربوط به تنظيمات سيستم عامل براي هر user است مثل تنظيمات desktop و محيط ويندوز
- HKEY_CURRENT_USER : شامل داده هاي کاربر فعلي سيستم
- HKEY_CLASSES_ROOT : شامل اطلاعات پيکربندي نرم افزار است مثل داده هاي OLE و داده هاي کلاسهاي متناظر با فايل
- HKEY_CURRENT_CONFIG : شامل اطلاعات مورد نياز براي تنظيمات داريورهاي سخت افزاري و غيره
2 – Key : key ها همانند folder ها و subfolder هاي روي هارد هستند . هر key متناظر با object هاي نرم افزاري يا سخت افزاري مي باشد . subkey ها key هايي هستند که درون يکسري key قراردارند .
3 – Entry : هر key داراي يک يا چند entry است . هر entry داراي سه بخش مي باشد :
- نام Name
- نوع داده اي Data Type : مقدار هر entry يکي از انواع داده هاي زير است :
REG_DWORD ، REG_SZ ، REG_EXPAND_SZ ، REG_BINARY ،
REG_MULTI_SZ ، REG_FULL_RESOURCE_DESCRIPTOT
- مقدار Value
نکته 1 : براي مشاهده رجيستري و اعمال تغييرات در آن ( لطفاً اگر هيچ تجربه اي در تنظيم کردن رجيستري نداريد اطلاعات آنرا تغيير ندهيد ) ، مي توانيد از برنامه regedit.exe و يا regedt32.exe موجود در ويندوز استفاده کنيد . براي اينکار کافيست نام برنامه را در کادر Run وارد کنيد .
---------------------
براي کار با رجيستري در ويژوال بيسيک کلاس Registery.bas را مطابق مطالب زير ايجاد کرده و در پروژه هاي خود از آن استفاده کنيد :

1 - تعريف ثابتهاي مورد نياز : براي نوشتن اين کلاس نياز به تعريف چهار دسته ثابت داريم :

- ثابتهاي مربوط به تعريف data type هاي entry هاي رجيستري :

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

- ثابتهاي مربوط به تعريف key هاي رجيستري

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

- ثابتهاي مربوط به خطاهاي کار با رجيستري

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

- ثابتهاي متفرقه

Global Const KEY_ALL_ACCESS = &H3F
Global Const REG_OPTION_NON_VOLATILE = 0

2 - Declare کردن Api هاي مورد نياز : براي کار با رجيستري از توابع کتابخانه Advapi32.dll استفاده مي کنيم . اين توابع عبارتند از :

- تابع RegCloseKey : آزاد کردن handle مربوط به يک key

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

- تابع RegCreateKeyEx : ساخت يک key در رجيستري ( اگر key قبلاً وجود داشته باشد ، اين تابع آنرا باز مي کند ) :

Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long

- تابع RegOpenKeyEx : باز کردن يک key

Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

- تابع RegQueryValueExLong : استخراج type و data ي يک نام متناظر با يک key باز شده

Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long

Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long

Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long

- تابع RegSetValueEx : ذخيره يک مقدار در فيلد value يک کليد باز

Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long

Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long

- تابع RegDeleteKey : پاک کردن يک کليد و کليه اطلاعات مرتبط با آن

Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)

- تابع RegDeleteValue : حذف مقدار يک key

Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)

3 - توابع کمکي : براي نوشتن توابع اصلي کار با رجيستري نياز به نوشتن توابع کمکي زير است :

- تابع SetValueEx : با توجه به نوع داده يک کليد ، مقدار موجود در آنرا در يک متغير ذخيره مي کند :

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ ' type of value is string
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))x
Case REG_DWORD ' type of value is Double word
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)x
End Select
End Function

- تابع QueryValueEx : سايز و نوع داده اي يک داده را که بايد خوانده شود مشخص مي کند .

Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)x
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)x
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)x
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)x
Else
vValue = Empty
End If
' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)x
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function

4 - توابع اصلي : توابع مربوط به پاک کردن يک کليد از رجيستري ، ساخت يک کليد جديد در رجيستري و مقداردهي به يک کليد :

- تابع DeleteKey : اين تابع يک کليد از رجيستري را حذف مي کند . داراي دو پارامتر ورودي است :
Location که يکي از مقادير HKEY_CLASSES_ROOT ، HKEY_CURRENT_USER
، HKEY_LOCAL_MACHINE و يا HKEY_USERS است .
KeyName که نام کليدي است که بايد از رجيستري حذف شود . اين کليد ممکنست شامل subkey هايي نيز باشد مثلاً Key1\SubKey1

Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)x
Dim lRetVal As Long
lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)x
DeleteKey = lRetVal ' return function value
End Function

- تابع DeleteValue : اين تابع يک entry را از کليد حذف مي کند . داراي سه پارامتر ورودي است : Location ، KeyName و ValueName که نام آن value را مشخص مي کند .

Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)x
Dim lRetVal As Long
Dim hKey As Long
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)x
lRetVal = RegDeleteValue(hKey, sValueName)x
RegCloseKey (hKey)x
DeleteValue = lRetVal
End Function

- تابع CreateNewKey : اين تابع يک کليد جديد ايجاد مي کند . داراي دو پارامتر ورودي است : Location و KeyName

Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)x
Dim hNewKey As Long
Dim lRetVal As Long
lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)x
RegCloseKey (hNewKey)x
CreateNewKey = lRetVal
End Function

- تابع SetKeyValue : اين تابع پارامتر data يک entry را تنظيم مي کند . داراي 5 پارامتر ورودي است : Location ، KeyName ، ValueName ، ValueSetting و ValueType

Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)x
Dim lRetVal As Long
Dim hKey As Long
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)x
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)x
RegCloseKey (hKey)x
SetKeyValue = lRetVal
End Function

- تابع QueryValue : اين تابع فيلد داده يک entry را برمي گرداند . داراي سه پارامتر ورودي است : Location ، KeyName و ValueName

Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)x
Dim lRetVal As Long
Dim hKey As Long
Dim vValue As Variant
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)x
lRetVal = QueryValueEx(hKey, sValueName, vValue)x
QueryValue = vValue
RegCloseKey (hKey)x
End Function

--------------------------
ساخت يک انتصاب فايل يا File Association به يک برنامه

در اين درس می خواهم با استفاده از کلاسی که در درس قبل معرفی شد تابعی بسازيم که توسط آن بتوانيم فايلهای با پسوندی مشخص را به يک برنامه اختصاص دهيم . بعبارت ديگر تابعی بنويسيم که اطلاعات لازم برای باز شدن فايلهايی با پسوند xxx را توسط برنامه MyApp.exe در رجيستری ثبت کند .


Public Sub CreateAssociation(sExtension As String, sApplication As String, sAppPath As String)x
Dim sPath, sAppExe As String
CreateNewKey "." & sExtension, HKEY_CLASSES_ROOT
SetKeyValue HKEY_CLASSES_ROOT, "." & sExtension, "", sApplication & ".Document", REG_SZ
CreateNewKey sApplication & ".Document\shell\open\command", HKEY_CLASSES_ROOT
SetKeyValue HKEY_CLASSES_ROOT, sApplication & ".Document", "", sApplication & " Document", REG_SZ
sPath = sAppPath & " %1"x
sAppExe = sApplication & ".exe"x
SetKeyValue HKEY_CLASSES_ROOT, sApplication& ".Document\shell\open\command", "", sPath, REG_SZ
CreateNewKey "Software\Microsoft\Windows\CurrentVersion\Explorer \FileExts\." & sExtension, HKEY_CURRENT_USER
SetKeyValue HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer \FileExts\." & sExtension, "Application", sAppExe, REG_SZ
CreateNewKey "Applications\" & sAppExe & "\shell\open\command", HKEY_CLASSES_ROOT
SetKeyValue HKEY_CLASSES_ROOT, "Applications\" & sAppExe & "\shell\open\command", "", sPath, REG_SZ
End Sub

کاربرد اين تابع بصورت زير است :

CreateAssociation("xxx","MyApp","c:\MyApp.exe")x

اجرا شدن يک برنامه در هنگام راه اندازی سيستم

فرض کنيد می خواهيم برنامه ای بنويسيم که هر بار در هنگام راه اندازي سيستم بطور خودكار اجرا شود. البته نمي خواهم در startup ويندوز ديده شود .
براي اين كار بايد برنامه موردنظر را در StartUp رجيستري قرار دهيم . به اين ترتيب كه در يكي از كليدهاي زير يك مقدار رشته اي جديد(String Value) ايجاد کنيم و آدرس برنامه را در آن وارد كنيم :

HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\Curre ntVersion\Run
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\Curr entVersion\Run

براي مثال اگه اسم برنامه مورد نظر MyApp و مسيرش C:\Windows\MyApp.exe است بايد بصورت زير عمل کرد :

SetKeyValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "MyApp", "C:\MyApp.exe", REG_SZ


نکته : البته دو تا راه ديگر برای اينکار وجود دارد که برخی تروجان ها هم از اين روشها استفاده می کنند تا روی سيستم باقی بمانند :
يكي استفاده از win.ini و نوشتن نام فايل جلوي = run و ديگري استفاده از system.ini و نوشتن نام برنامه جلوي خط explorer.exe .

[parsiyan_mohsen]

آشنايي با Windows API : واژه API مخفف Application Programming Interface مي باشد . API هاي ويندوز مجموعه اي از توابع از پيش آماده موجود در سيستم عامل هستند که شما مي توانيد آنها را در برنامه هاي خود فراخواني کنيد . اين توابع در چندين کتابخانه DLL ويندوز ذخيره شده اند . براي دسترسي به اين توابع در ويژوال بيسيک ابتدا بايد آنها را برنامه خود declare کنيد . براي مثال :


Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

همانطور که مي بينيد مثال فوق يک Declare از تابع sndPlaySound مي باشد که اين تابع در کتابخانه Winmm.dll موجود است . کلمه Alias نشان مي دهد که اين تابع نام ديگري در dll دارد . ساير بخشها مربوط به تعريف پارامترهاي تابع مي باشند که در مورد مثال فوق ، اين تابع دو پارامتر ورودي و يک خروجي از نوع Long دارد .
پس از Delare کردن API در برنامه مي توانيد از آن استفاده نمائيد .

۲ - پخش فايلهاي Wav : تابعي که براي پخش فايلهاي Wav استفاده مي شود تابع sndPlaySound است که در بالا با آن آشنا شديد . پارامتر lpzSoundName نام و مسير فايل Wavو پارامتر uFlags چگونگي پخش فايل را مشخص مي کند . مقادير ممکن اين پارامتر عبارتند از :
- SND_ASYNC : اجازه مي دهد طوري فايل Wav پخش شود که آنرا بتوان وقفه داد . بعبارت ديگر قادر خواهيد بود فايل Wav تان را هر زمان که بخواهيد پخش کنيد و مطمئن باشيد که حتماً شنيده مي شود .
- SND_LOOP : فايل Wav را بطور ممتد پخش مي کند .
- SND_NODEFAULT : اگر فايل Wav پيدا نشود صداي ديگري پخش نخواهد شد ( مثلاً برخي صداهاي default ويندوز )
- SND_SYNC : در طول پخش فايل Wav کنترل به برنامه داده نمي شود . اين پارامتر در زمانيکه مي خواهيد فايل Wav اي را در پس زمينه برنامه تان پخش کنيد مناسب نمي باشد .
- SND_NOSTOP : اگر فايل Wav اي قبلاً در حال پخش باشد ، فايل Wav شما آنرا دچار وقفه نمي کند . از اين پارامتر زماني استفاده مي شود که بخواهيم فايل Wav مان هيچوقت در وسط کار قطع نشود .
اگر بخواهيد از بيش از يکي از اين پارامترها استفاده کنيد توسط Or آنها را ترکيب نمائيد مثال :


sndPlaySound App.path & "\ding.wav", SND_ASYNC or SND_LOOP


نکته : براي استفاده از توابع صوتي پيچيده تر بايستي از DirectSound که يکي از اجزاي DirectX مي باشد استفاده کنيد . در مورد DirectSound بعداً صحبت خواهم کرد .

۳ - ساخت يک تايمر با دقت بالا : شايد تا بحال از کنترل تايمر موجود در نوار ابزار ويژوال بيسيک استفاده کرده باشيد . اين تايمر داراي دقت حدود ۵۵ ميلي ثانيه است . براي دستيابي به زمانهاي با دقت بالاتر اين کنترل مفيد نخواهد بود .
تابع GetTickCount يک API موجود در کتابخانه Kernel32.dll است . اين تابع طول زماني را که سيستم شروع به کار کرده است را برحسب ميلي ثانيه برمي گرداند :


Private Declare Function GetTickCount Lib "kernel32" () As Long
براي بررسي طي شدن يک مدت زماني خاص شما ابتدا بايد مقدار اين تابع را در يک متغير کمکي مثل TempTime قرار دهيد سپس در يک حلقه Do-Loop بايد اختلاف زمان GetTickCount جديد و زمان TempTime را با مقدار زماني که مي خواهيد سپري شود مقايسه کنيد :


TempTime = GetTickCount()x
Do While DesiredTime < GetTickCount() - TempTime
Do some things'
Loop

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


ExitFunction = False
TempTime = GetTickCount()x
Do While not(ExitFunction)x
If DesiredTime < GetTickCount() - TempTime then
Reset the temporary variable'
TempTime = GetTickCount()x
Do some things'
End If
Loop

همچنين از تابع GetTickCount مي توان براي benchmark برنامه ها استفاده کرد . بعبارت ديگر مي توان زمان اجراي يکسري دستورات خاص را بدست آورد .

[parsiyan_mohsen]

مطالبی در مورد کنترل WINSOCK
کنترل WinSock نسبت به تمام کنترلهاي اينترنت در سطح پايينتري قرار دارد . اين کنترل امکان ايجاد سرويسهاي شبکه اي مبتني بر پروتکلهاي TCP و UDP را مهيا مي کند . بعبارت ديگر توسط اين کنترل مي توان برنامه هاي کاربردي Client/Server ( سرويس گيرنده / سرويس دهنده ) ايجاد و با استفاده از پروتکل TCP و يا UDP بين آنها ارتباط برقرار نمود .
با تنظيم خصوصيات و فراخواني متدهاي اين کنترل مي توانيد به راحتي به يک کامپيوتر راه دور متصل شويد و داده ها را در هر دو جهت جابجا نمائيد . نمونه کاربرهايي که مي توان با اين کنترل ايجاد نمود :
Client-server chat ، Mail client ، Mail server ، Proxy Server ، Network Game ، Port Scanner ، پياده سازي الگوريتم هاي موازي و …
مباني TCP :
پروتکل کنترل اينترنت ( Transfer Control Protocol ) اجازه مي دهد يک اتصال ( Connection ) را از طريق سوکت ( socket ) به يک کامپيوتر راه دور ( Remote Computer ) ساخته و استفاده کنيد . با استفاده از اين اتصال ، هر دو کامپيوتر مي توانند داده ها را بين خودشان انتقال دهند . برقراري ارتباط از طريق TCP همانند صحبت کردن با تلفن است که بايد حتماً اتصالي بين دو کامپيوتر صورت گيرد تا بتوانند با هم ارتباط برقرار کنند .
اگر يک برنامه Client مي سازيد بايستي بدانيد که نام يا آدرس IP کامپيوتر Server چيست ( Remote Host IP ) و همچنين از طريق چه پورتي مي توانيد به آن متصل شويد ( Remote Port ) . حال بايستي به آن پورت Connect کنيد .
همچنين اگر يک برنامه Server مي سازيد بايستي پورتي را که روي آن به درخواستها گوش مي دهيد مشخص کنيد ( LocalPort ) و سپس به پورت گوش دهيد ( Listen ) .
زمانيکه يک کامپيوتر Client تقاضاي يک اتصال را مي دهد Server اين درخواست را Accept مي کند .
زمانيکه يک اتصال ساخته مي شود ، هر دو کامپيوتر مي توانند داده را فرستاده و دريافت کنند .
مباني UDP :
پروتکل ديتاگرام کاربر ( User Datagram Protocol ) پروتکلي بدون اتصال ( Connectionless ) است . برخلاف TCP ، کامپيوترها نياز به برپا کردن يک اتصال ندارند بنابراين يک برنامه مي تواند يک client و يا يک server باشد . برقراري ارتباط در UDP شبيه ارسال نامه از طريق پست است .
براي انتقال داده توسط UDP ابتدا بايد Local Port کامپيوتر Client تنظيم گردد . کامپيوتر Server تنها بايستي RemoteHost را برابر آدرس کامپيوتر Client قرار دهد و همچنين Remote Port را همان Local Port کامپيوتر Client قرار دهد . سپس دو کامپيوتر مي توانند داده ها را بين خود جابجا کنند .
استفاده از کنترل WinSock :
1 – انتخاب پروتکل: در زمان استفاده از کنترل WinSock اولين کاري که بايد انجام دهيد انتخاب يکي از پروتکلهاي TCP يا UDP است . طبيعت برنامه اي که شما مي سازيد نوع پروتکلي را که بايد استفاده کنيد مشخص مي کند . چند سوال زير به شما کمک مي کند که پروتکل مورد نيازتان را انتخاب کنيد :
- آيا برنامه شما در زمانيکه داده فرستاده مي شود يا دريافت مي شود نياز به اطلاعاتي از طرف Server يا Client دارد ؟ اگر چنين است بايستي يک اتصال TCP قبل از ارسال يا دريافت داده ايجاد شود .
- آيا داده بسيار بزرگ است ( مثل تصوير يا فايلهاي صوتي ) ؟ زمانيکه يک اتصال TCP ساخته مي شود پروتکل TCP اتصال را باقي نگه مي دارد و درستي ارسال داده تضمين شده است . اين اتصال در هر حال به منابع محاسباتي بيشتري نياز دارد و بنابراين پرهزينه تر است .
- آيا داده متناوب ارسال مي شود يا در يک نشست ( Session ) ارسال خواهد شد ؟ براي مثال اگر شما يک برنامه مي سازيد که کامپترهاي مشخصي را در يک زمان خاص از انجام شدن عملياتي مطلع مي کند پروتکل UDP مناسب تر است . پروتکل UDP همچنين براي ارسال مقادير کوچک داده اي مناست تر مي باشد .
2 – تنظيم پروتکل : براي تنظيم پروتکلي که مي خواهيد در برنامه تان از آن استفاده کنيد در زمان طراحي برنامه خاصيت Protocol کنترل WinSock را برابر sckTCPProtocol و يا sckUDPProtocol قرار دهيد . همچنين مي توانيد پروتکل خود را توسط کد زير تنظيم کنيد :


WinSock.Protocol=sckTCPProtocol
3 – مشخص کردن نام کامپيوتان : براي اتصال به کامپيوتر راه دور بايستي آدرس IP و يا نام کامپوتر را بدانيد .
نام کامپيوتر در Control Panel/Network/Identification موجود است . در صورتيکه مي خواهيد دو برنامه Client و Server خود را روي يک کامپيوتر تست کنيد از آدرس IP 127.0.0.1 براي هر دو استفاده کنيد اما اگر دو برنامه را روي دو کامپيوتر مجزا در شبکه قرار داده ايد با اجراي دستور ipconfig در DOS Prompt مي توانيد آدرس IP کامپيوتر ها را بدست آوريد .
4 – ايجاد اتصال TCP : در زمان ساخت برنامه اي که از پروتکل TCP استفاده مي کند ابتدا بايد تصميم بگيريد که اين برنامه Client است يا Server . براي ساخت يک برنامه Server بايستي روي يک پورت خاص Listen کنيد . زمانيکه Client تقاضاي يک اتصال را مي دهد ، برنامه Server مي تواند آنرا Accept کند و بنابراين اتصال کامل شده است . حال Client و Server مي توانند با هم ارتباط داشته باشند .
مراحل زير ساخت يک سرور چت ساده بر مبناي TCP را نشان مي دهد :
- از منوي Project گزينه Components را انتخاب کنيد و در ليست Component ها مورد Microsoft WinSock 6.0 را انتخاب کنيد .
- يک کنترل WinSock در فرم خود قرار دهيد و نام آنرا tcpserver بگذاريد
- دو textbox با نامهاي txtSendData و txtReceiveData و نيز يک دکمه در فرم قرار دهيد .
- کد زير را در رويداد Form_Load بنويسيد :


Tcpserver.LocalPort=1000
tcpserver.Listen

- زمانيکه درخواستي از طرف Client مي آيد رويداد ConnectionRequest اجرا مي شود . در اين رويداد ابتدا بايد چک کنيد که حالت کنترل بسته باشد . اگر چنين نيست اتصال را قبل از پذيرفتن اتصال جديد ببنديد . سپس تقاضا را بر اساس پارامتر requestID مي پذيريم :


Private Sub tcpserver_ConnectionRequest(ByVal requestID As Long)
If tcpserver.State <> sckClosed Then tcpserver.Close
tcpserver.Accept requestID
End Sub

- حال اتصال بين Client و Server برقرار شده است . کد زير را براي event مربوط به کليک دکمه Send بنويسيد :


Tcpserver.SendData txtSendData.text
- اگر داده اي از طرف Client بيايد رويداد DataArrival اجرا مي شود . کد زير را براي اين رويداد بنويسيد :


Private Sub tcpserver_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
tcpserver.GetData strData
txtReceiveData.Text = strData
End Sub

- کد زير را براي رويداد Form_Unload بنويسيد :


Tcpserver.Close
مراحل ساخت يک TCP Client بصورت زير است :
- يک کنترل WinSock در فرم قرار دهيد و نام آنرا tcpclient بگذاريد .
- دو textbox با نامهاي txtsend و txtreceive و نيز يک دکمه با نام sendدر فرم قرار دهيد .
- يک دکمه با نام connect در فرم قرار دهيد .
- کد زير را براي متد Form_Load بنويسيد :


tcpclient.RemoteHost=”yourservername”x
tcpclient.RemotePort=1000

- کد زير را براي رويداد کليک شدن دکمه connect بنويسيد :


tcpclient.Connect
- کد زير را براي رويداد کليک شدن دکمه send بنويسيد :


tctclient.SendData txtsend.Text
- کد زير را براي رويداد DataArrival بنويسيد :


Private Sub tcpclient_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
tcpclient.GetData strData
txtreceive.Text = strData
End Sub

- کد زير را باري رويداد Form_Unload بنويسيد :


Tcpclient.Close
کدهاي فوق يک سيستم Client-Server ساده را نشان مي دهد . فايل exe هر دو برنامه را بسازيد و آنها را اجرا کنيد تا بتوانيد سيستم خود را تست کنيد .
5 – پذيرفتن بيش از يک تقاضاي اتصال : Server اي که در بالا ساخته شد تنها مي تواند تقاضاي يک اتصال را بپذيرد . با استفاده از ايجاد يک آرايه از کنترل WinSock مي توان چندين تقاضاي اتصال را پذيرفت . براي اينکار کافي است يک کپي ( instance ) از کنترل بسازيم ( با تنظيم خاصيت Index ) و متد Accept را براي instance جديد بکار ببريم . فرض کنيد يک کنترل WinSock با نام sckServer در فرم داريم که خاصيت Index آنرا صفر قرار داده ايم . همچنين يک متغير intMax از نوع Long تعريف مي کنيم که تعداد اتصالات همزمان به Server را نگه مي دارد . در event مربوط به Form_Load کد زير را بنويسيد :


intMax=0
sckServer(0).LocalPort=1000
sckServer(0).Listen

هر بار که تقاضاي يک اتصال مي رسد کد ابتدا تست مي کند که مقدار Index چقدر است . اگر مقدار Index صفر باشد متغير intMax يکي افزايش مي يابد و از intMax براي ساخت يک instance جديد از کنترل استفاده مي شود . حال از اين instance براي پذيرفتن تقاضاي اتصال استفاده مي گردد . براي اينکار کد زير را براي رويداد ConnectionRequest بنويسيد :


Private Sub sckServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
If Index = 0 Then
intmax = intmax + 1
Load sckServer(intmax)x
sckServer(intmax).LocalPort = 0
sckServer(Index).Accept requestID
End If
End Sub
6 – ايجاد اتصال UDP : ساخت يک برنامه UDP ساده تر از برنامه هاي TCP است زيرا پروتکل UDP به اتصال نياز ندارد . در برنامه TCP بالا يک کنترل WinSock بايستي حتماً Listen مي کرد و يک کنترل ديگر يک اتصال را توسط متد Connect ايجاد نمود . در عوض پروتکل UDP نيازي به اتصال ندارد . براي ارسال داده بين دو کنترل WinSock سه مرحله بايستي انجام شود :
- پارامتر RemoteHost برابر نام کامپيوتر مقابل است .
- پارامتر RemotePort برابر پارامتر LocalPort کامپيوتر مقابل
- استفاده از متد Bind براي مشخص کردن LocalPort
چون هر دو کامپيوتر از نظر ارتباط مساوي هستند ، اين نوع برنامه ها را Peer-to-Peer گويند . براي نمونه از کد زير براي ساخت يک برنامه chat استفاده مي کنيم :
- يک کنترل WinSock در فرم قرار دهيد و نام آنرا udppeerA بگذاريد .
- خاصيت Protocol آنرا UDPProtocol قرار دهيد .
- دو textbox با نامهاي txtsend و txtreceive و نيز يک دکمه در فرم قرار دهيد .
- کد زير را براي متد Form_Load بنويسيد :


udppeerA.RemoteHost=”nameofpeerB”x
udppeerA.RemotePort=1001
udppeerA.Bind 1002

- کد زير را براي event مربوط به کليک دکمه بنويسيد :


udppeerA.SendData txtsend.text
- کد زير را براي رويداد DataArrival بنويسيد :


Dim strData as String
udppeerA.GetData strData
txtreceive.Text=strData

براي ساخت UDP peerB مشابه مراحل بالا عمل کنيد فقط خاصيت RemoteHost آنرا نام کامپيوتر PeerA و خاصيت RemotePort آنرا 1002 و خاصيت Bind آنرا 1001 قرار دهيد .
-------------------
بررسی خواص کنترل WinSock :
ByteReceived : مقدار داده دريافت شده ( موجود در بافر receive ) را نشان مي دهد . توسط متد GetData مي توان اين داده را دريافت نمود .
LocalHostName : نام ماشين محلي را نشان مي دهد . اين پارامتر فقط خواندني است .
LocalIP : آدرس IP ماشين محلي را بصورت يک string برمي گرداند . اين پارامتر فقط خواندني است .
LocalPort : براي خواندن و يا تنظيم شماره پورت محلي بکار مي رود .
Protocol : براي خواندن و يا تنظيم پروتوکل مورد استفاده توسط کنترل WinSock بکار مي رود .
RemoteHost : براي خواندن و يا تنظيم نام يا آدرس IP ماشين راه دور بکار مي رود .
RemoteHostIP : آدرس IP ماشين راه دور را برمي گرداند :
۱- براي برنامه هاي Client بعد از زمانيکه يک اتصال توسط متد Connect پذيرفته شد ، اين خاصيت حاوي آدرس IP ماشين راه دور است .
۲ - براي برنامه Server ، بعد از آمدن يک Connection Request اين خاصيت شامل آدرس IP ماشين راه دور است .
۳ - در زمان استفاده از پروتکل UDP بعد از اينکه رويداد Data Arrival رخ داد اين خاصيت حاوي آدرس IP ماشيني است که داده را فرستاده .
RemotePort : براي خواندن و يا تنظيم شماره پورت ماشين راه دوري که مي خواهيد به آن متصل شويد بکار مي رود .
SocketHandle : مقداري را برمي گرداند که مرتبط با سوکتي است که کنترل WinSock را مديريت مي کند و براي ارتباط با لايه WinSock بکار مي رود . اين پارامتر فقط خواندني است و تنها براي ارسال به API هاي WinSock طراحي شده است .
State : وضعيت کنترل WinSock را نشان مي دهد . وضعيتهاي ممکن براي State عبارتند از :
۱ - sckClosed : اتصال بسته است .
۲ - sckOpen : اتصال باز است .
۳ - sckListening : حالت گوش دادن به پورت
4 - sckConnectionPending : معلق شدن اتصال
۵ - sckResolvingHost : تصميم گيري در مورد ميزبان
۶ - sckHostResolved : در مورد ميزبان تصميم گيري شد .
۷ - sckConnecting : حالت برقراري ارتباط
۸ - sckConnected : ارتباط برقرار شد .
۹ - sckClosing : حالت قطع اتصال
۱۰ - sckError : حالت خطا

بررسی متدهای کنترل WinSock :
متد Accept : تنها براي برنامه هاي TCP Server بکار مي رود . اين متد براي پذيرفتن يک اتصال در زمان مديريت رويداد ConnectionRequest استفاده مي شود .
متد Bind : اين پارامتر LocalPort و LocalIP يک اتصال را مشخص مي کند .
متد Close : براي بستن يک اتصال TCP و يا بستن يک listening socket بکار مي رود .
متد GetData : بلوک جاري داده دريافت شده را گرفته و آنرا در متغيري از نوع Variant ذخيره مي کند . شکل کلي اين متد بصورت زير است :


WinSock.GetData data[,type][,maxlen]x
که data داده دريافتي است . اگر داده کافي موجود نباشد data برابر empty خواهد بود .
type نوع داده دريافتي است که مي تواند مقادير زير باشد :
vbByte - vbInteger - vbLong - vbSingle - vbDouble - vbDate - vbBoolean - vbError - vbString - vbArray+vbByte
maxlen حداکثر سايز را در زمان دريافت يک byte Array و يا يک string مشخص مي کند .
متد Getdata در رويداد Data Arrival استفاده مي شود که اين رويداد يک پارامتر با نام TotalBytes دارد . اگر maxlen اي که شما تعيين کرده ايد کمتر از TotalBytes باشد پيغام هشدار شماره ۱۰۰۴۰ دريافت مي کنيد بدين معني که بايتهاي باقيمانده گم خواهند شد .
متد Listen : يک سوکت مي سازد و آنرا در حالت Listen قرار مي دهد . اين متد تنها در اتصالات TCP بکار ميرود .
متد PeekData : مشابه GetData است با اين تفاوت که داده را از صف ورودي حذف نمي کند . اين متد تنها براي اتصالات TCP بکار مي رود .
متد SendData : براي ارسال داده به کامپيوتر راه دور بکار مي رود .
بررسي event هاي کنترل WinSock :
رويداد Close : زماني رخ مي دهد که کامپيوتر راه دور اتصال را ببندد .
رويداد Connect : بعد از اينکه يک اتصال به Server ايجاد شد روي مي دهد . شکل کلي آن بصورت زير است :


Private Sub WinSock_Connect(ErrorOccurred As Boolean)x
که پارامتر ErrorOccurred دو مقدار دارد : اگر True باشد يعني اتصال Fail شده است و اگر False باشد يعني اتصال با موفقيت انجام شده است .
با رويداد Connect مي توانيد error هايي که در زمان فرايند باز کردن اتصال برگردانده شده را چک کنيد .
رويداد ConnectionRequest : زماني رخ مي دهد که يک کامپيوتر راه دور تقاضاي يک اتصال را بدهد . اين رويداد فقط براي برنامه هاي TCP Server بکار مي رود .
رويداد DataArrival : زماني رخ مي دهد که داده جديدي بيايد .
رويداد Error : زماني رخ مي دهد که يک خطا در فرايند ارتباط رخ دهد ( مثلاً Failed to Connect و يا Failed to Send ) . شکل کلي آن بصورت زير است :


Private WinSock_Error(number as Integer,description as String,scode as Long,source as String,helpfile as String,helpcontext as Long,canceldisplay as Boolean)x

number شماره کد خطا است .
description توضيحي در مورد خطا است .
source توصيف منبع خطا
canceldisplay : مشخص مي کند آيا پيغام خطاي پيش فرض نشان داده شود يا نه
رويداد SendComplete : زماني رخ مي دهد که يک عمل Send تکميل شده باشد .
رويداد SendProgress : زماني رخ مي دهد که کنترل شروع به ارسال داده نمايد . شکل کلي آن بصورت زير است :


WinSock_SendProgress (bytesSent As Long, bytesRemaining As Long)x

که bytesSent تعداد بايتهاي ارسال شده و bytesRemaining تعداد بايتهاي باقيمانده است .

[parsiyan_mohsen]

رویداد ها در ویژوال بیسیک
براي هر عملي که ميخواهيم کاربر در برنامه ما انجام دهد مي بايست در هر رويداد کد خاصي را بنويسيم تا نسبت به رفتار خاصي پاسخگو باشيم اين رويدادها تعيين ميکنند که برنامه ما نسبت به چه اعمالي حساس باشد کليک کردن يا فشردن دکمه اي خاص.
عمل کليک : تو مثالهاي قبلي وقتي رو Command1 کليک ميکرديم يه عملي انجام ميشد چون ما تو رويداد کليک Command1 اون کدمون رو نوشتيم حالا اگه بخواهيم رويدادهاي ديگه اي هم هستن مثلا KeyDown ويا MouseMove و ... همه اينها بسته به نوعشون در مقابل رفتار کاربر عمل بخصوصي رو انجام ميدن حالا چند تا کد مينويسيم که با رويدادهاي مختلف آشنا بشيم :
MouseMove:زماني که ماوس رو باتن حرکت کنه Caption باتن عوض ميشه.

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Command1.Caption = "Mosee Move !"End Sub

MouseDown: اگر دکمه فشار داده شود (هنوز دستمان روي دکمه ماوس است دکمه بالا نيامده)

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Command1.Caption = "Mosee Down !"End Sub

MouseUp : دکمه ماوس فشار داده شده و به سمت بالا رها مي شود بعد از عمل MouseDown

Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Command1.Caption = "Mosee Up !"End Sub
رويدادهاي KeyDown وKeyPress وKeyUp هم مثل همين ها هستند تنها تفاوت چون نياز به يک دستور شرطي دارند(با يک دستور شرطي مشخص ميکنيم اگر کليد فشرده شده مثلا Ctrl بود چه عملي انجام شود) بعدا که دستورات شرطي رسيديم ميگم .DragDrop و DragOver هم همچنين.+
ولي حالا ميخواهيم يه برنامه ساده بنويسيم که از کنترل Label استفاده مي شه . يه کنترل ليبل از سمت چپ انتخاب کنين و بندازين تو صفحه فرمتون ! برنامه ما اين کار رو ميکنه -[وقتي ماوس رو ليیل ميره رنگ اون عوض ميشه و Bold هم ميشه مثل همين لينک ها و وقتي هم ماوس رو از روش برمي داريم به حالت اول بر ميگرده ]- خب اول براي رويداد MouseMove اينها رو مينويسيم:

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Label1.ForeColor = &HFF& Label1.FontBold = TrueEnd Sub

و در رويداد Form_MouseMove هم اينها رو مينويسيم(همين ها رو کپي و پيست کنين)

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Label1.ForeColor = &H80000007 Label1.FontBold = FalseEnd Sub

حالا برنامه رو اجرا کنين ماوس رو روي ليبل بذارين و از روش بردارين

[parsiyan_mohsen]

آشنایی (mk:@MSITStore:H:\Project.1\dev.ir.chm::/www.dev.ir/articles/show.asp@id=104.htm) با BITBIT
هدف از اين مبحث آموزشي ، آشنايي با تابع BitBlt و برخي ديگر از توابع کتابخانه Win32 GDI براي انجام برخي عمليات گرافيکي مثل double buffering و خواندن sprite از فايل است .
نکته : sprite به کاراکترهاي متحرکي گفته مي شود که در بازيها وجود دارد .
اولين چيزي که به آن نياز داريد ايجاد يک فرم است . خاصيت ScaleMode آنرا برابر 3-Pixel قرار دهيد . پيشنهاد مي کنم که هميشه در هنگام استفاده از فرم بهمراه API از pixel براي scalemode استفاده کنيد .
سپس سايز فرم را به اندازه اي افزايش دهيد تا ScaleWidth برابر 320 و ScaleHeight برابر 256 شود . توجه کنيد که خاصيت HasDC فرم را True قرار دهيد . همچنين از خاصيت AutoRedraw براي فرم استفاده نمي کنيم زيرا مي خواهيم از Double Buffering استفاده کنيم که بسيار سريعتر و کارامدتر مي باشد .
مرحله بعدي declare کردن API هايي است که به آنها نياز داريم :

'blitting
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
'code timer
Private Declare Function GetTickCount Lib "kernel32" () As Long
'creating buffers / loading sprites
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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
'loading sprites
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'cleanup
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

سوال : DC چيست ؟ DC و يا بعبارت ديگر Device Context ، hDC يک عدد است که به يک آدرس در حافظه اشاره مي کند که داده اي در آن ذخيره شده است . در هنگام استفاده از BitBlt براي اشاره کردن به آدرسي که داده گرافيکي در آنجا ذخيره شده ، استفاده مي شود .
در مرحله بعدي نياز به ذخيره آدرسهاي DC داريم که مي سازيم . آدرسهاي DC مقادير Long هستند همچنين آنها را بصورت Public تعريف مي کنيم :

'our Buffer's DC
Public myBackBuffer As Long
Public myBufferBMP As Long
'The DC of our sprite/graphic
Public mySprite As Long
'coordinates of our sprite/graphic on the screen
Public SpriteX As Long
Public SpriteY As Long

حال بايد تابعي بسازيم که تصاوير گرافيکي درون حافظه load کند . نکته مهمي که بايد به آن توجه کنيد اينست که يک device context خودش به تنهايي هيچ داده گرافيکي ندارد و بايستي يک bitmap موجود باشد تا درون آن load شود براي مثال يک فايل bmp يا يک bitmap خالي که از آن بعنوان back buffer استفاده مي کنيد .
تابعي که خواهيم نوشت يک device context منطبق با صفحه مي سازد سپس فايلهاي گرافيکي مورد نظر را درون device context قرار مي دهد :

Public Function LoadGraphicDC(sFileName As String) As Long
'temp variable to hold our DC address
Dim LoadGraphicDCTEMP As Long
'create the DC address compatible with
'the DC of the screen
LoadGraphicDCTEMP = CreateCompatibleDC(GetDC(0))
'load the graphic file into the DC...
SelectObject LoadGraphicDCTEMP, LoadPicture(sFileName)
'return the address of the file
LoadGraphicDC = LoadGraphicDCTEMP
End Function

سوال : double-buffering چيست ؟ زمانيکه يک محيط گرافيکي مي سازيد تا درون آن چيزي را ترسيم کنيد ، شما sprite ها / گرافيکها / متن را درون حافظه blit مي کنيد ( offscrean ) سپس نتيجه نهايي را روي صفحه blit مي کنيد . اين عمل از لرزش تصوير يا flickering جلوگيري مي کند ( زماني رخ مي دهد که چندين sprite مستقيماً روي صفحه blit شوند ) و بسيار سريعتر از AutoRedraw است .
قبل از اينکه مثالي براي اين تابع ذکر کنم تابع BitBlt را توضيح خواهم داد :
BitBlt تابعي از کتابخانه dll “gdi32” است . اين تابع يک انتقال bit-block از داده هاي مرتبط به يک مستطيل از پيکسلها به يک device context مقصد انجام مي دهد . بعبارت ديگر داده هاي گرافيکي را از محيط گرافيکي ( يک bitmap ) به محيط گرافيکي ديگري ( screen يا يک form ) کپي مي کند . فرم کلي اين تابع بصورت زير است :

Declare Function BitBlt Lib "gdi32" Alias "BitBlt" _
(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

اولين خط بيان مي کند که ما بوسيله gdi32 DLL به تابع BitBlt دسترسي خواهيم داشت . خطوط ديگر پارامترهايي هستند که اين تابع مي گيرد :
hDestDC : hDC مربوط به محيط مقصد ( اگر مي خواهيد مقصد يک فرم باشد از form.hDC استفاده کنيد و يا اينکه آدرس يک backbuffer را که ساخته ايد بدهيد )
x : مختصات افقي محلي که مي خواهيد گرافيک شما ظاهر شود .
y : مختصات عمدي محلي که مي خواهيد گرافيک شما ظاهر شود .
nWidth : عرض گرافيک شما
nHeight : ارتفاع گرافيک شما
hSrcDC : hDC مربوط به محيط مبدا
xSrc : افست x . 0 زماني استفاده مي شود که بخواهيد از سمت چپترين گوشه گرافيک مبدا عمل blit را انجام دهيد .
ySrc : افست y
dwRop : مد draw اي که در زمان blitting گرافيکتان مي خواهيد استفاده کنيد ( Raster Operations يا ROP ) . اين پارامتر مقادير زير را مي تواند بگيرد :
- vbSrcCopy : داده تصوير مبدا را مستقيماً در مقصد کپي مي کند .
- vbSrcPaint : داده هاي تصاوير مبدا و مقصد را با هم OR مي کند ( pseudo-alphablending effect )
- vbSrcAnd : داده هاي تصاوير مبدا و مقصد را با هم AND مي کند ( pseudo-gamma effect )
- vbSrcInvert : داده هاي تصاوير مبدا و مقصد را با هم XOR مي کند
- vbSrcErase : ابتدا داده تصوير مقصد را invert مي کند سپس آنرا با داده تصوير مبدا AND مي کند .
- vbDstInvert : داده تصوير مقصد را invert مي کند و داده تصوير مبدا را در نظر نمي گيرد .
- vbNotSrcCopy : داده تصوير مبدا را invert مي کند و آنرا مستقيماً در مقصد کپي مي کند .
- vbNotSrcErase : داده تصاوير مبدا و مقصد را OR کرده و نتيجه را invert مي کند .

مثالي از کاربرد BitBlt :
BitBlt Form1.hDC, PlayerX, PlayerY, 48, 48, picPlayer.hDC, 0, 0, vbSrcCopy

حال مي خواهيم از BitBlt در يک حلقه استفاده کنيم تا يک image را در فرم حرکت دهيم :
1 – يک فايل bmp با ابعاد 32x32 بسازيد و با نام sprite1.bmp در دايرکتوري پروژه ذخيره کنيد .
2 – يک دکمه در فرم قرار دهيد و نام آنرا cmdTest بگذاريد .
3 – دکمه را در گوشه بالايي فرم و در سمت راست قرار دهيد .
4 – کد زير را براي event مربوط به کليک شدن دکمه بنويسيد :

'Timer variables...
Dim T1 As Long, T2 As Long
ساخت DC براي backbuffer’
myBackBuffer = CreateCompatibleDC(GetDC(0))
ساخت يک سطح bitmap براي DC’
myBufferBMP = CreateCompatibleBitmap(GetDC(0), 320, 256)
load کردن سطح bitmap خالي درون buffer’
SelectObject myBackBuffer, myBufferBMP
قبل از blit کردن درون بافر بايد آنرا با black پر کنيم’
BitBlt myBackBuffer, 0, 0, 320, 256, 0, 0, 0, vbWhiteness
load کردن split توسط تابعي که در بالا نوشتيم’
mySprite = LoadGraphicDC(App.Path & "\sprite1.bmp")
cmdTest.Enabled = False
== شروع حلقه اصلي ==’
خواندن tickcount جاري’
T2 = GetTickCount
Do
DoEvents
T1 = GetTickCount
اگر 15 ميلي ثانيه گذشته بود فريم بعدي شروع شود’
If (T1 - T2) >= 15 Then
پاک کردن محل قبلي sprite بوسيله پر کردن آنجا با black ‘
BitBlt myBackBuffer, SpriteX - 1, SpriteY - 1,32, 32, 0, 0, 0, vbBlackness
Blit کردن sprite درون back buffer’
BitBlt myBackBuffer, SpriteX, SpriteY, 32, 32,mySprite, 0, 0, vbSrcPaint
Blit کردن backbuffer روي فرم’
BitBlt Me.hdc, 0, 0, 320, 256, myBackBuffer,0, 0, vbSrcCopy
حرکت دادن sprite روي صفحه’
SpriteX = SpriteX + 1
SpriteY = SpriteY + 1
'update timer
T2 = GetTickCount
End If
Loop Until SpriteX = 320
سپس بايد يک cleanup code بنويسيد تا حافظه هاي را که براي نگهداري تصاوير گرافيکي و buffer ها استفاده کرده ايد آزاد کنيد :

Private Sub Form_Unload(Cancel As Integer)
DeleteObject myBufferBMP
DeleteDC myBackBuffer
DeleteDC mySprite
End
End Sub

[parsiyan_mohsen]

ايجاد کلاسی برای کار با فايلهای XML
برای قرار دادن پارامترهای اتصال به بانک اطلاعاتی از فايل XML استفاده خواهيم نمود . بنابراين ابتدا بايستی کلاسی برای کار با فايلهای XML بنويسيم . توجه داشته باشيد که کلاسی که در اين بخش معرفی می شود کلاسی ساده می باشد که فقط با آن می توان مقدار يک ند Node وجود در فايل xml را خواند . در صورت نياز ، می توانيد خودتان متدهای ديگری را به آن اضافه کنيد . برای اين منظور نکاتی را در انتهای همين بخش آورده ام .
XML يک زبان نشانه ای توسعه پذير ( eXtensible Markup Language ) است که در سال 1998 توسط کنسرسيوم وب جهانی W3C ايجاد شد . XML واقعاً يک زبان نيست بلکه يک متا-زبان است و برای توصيف ساير زبانها بکار می رود . داده ها در فايلهای XML براحتی قابل تعريف و استفاده هستند .
مثالی از يک فايل XML :



<user>
<name>ali</name>
<id>12</id>
</user>


کار با فايلهای XML در وی بی :
برای کار با فايلهای xml در ويژوال بيسيک بايستی ابتدا از بخش References مورد Microsoft XML 3.0 را انتخاب کنيد . سپس يک Class Modules به پروژه تان اضافه کنيد و نام آنرا XMLReader بگذاريد . در اين کلاس ابتدا يک متغير از نوع شی xml برای کار با فايلهای xml تعريف می کنيم :


Private xml

سپس متدی برای مقداردهی اوليه شی xml می نويسيم . اين متد دارای يک متغير ورودی است که نام فايل xml مورد نظر می باشد :


Public Sub Initiate(ByVal filename As String)x
Set xml = CreateObject("Microsoft.XMLDOM")x
xml.async = False
xml.Load (server.MapPath(filename))x
End Sub

توجه کنيد که در کد فوق از شی server برای يافتن مسير فيزيکی فايل XML استفاده شده است بنابراين ابتدا بايستی در Class_Initialize اين شی را مطابق مطالب درس دوم مقداردهی کنيد .

حال بايستی متدی برای خواندن مقدار يک ند از فايل xml بنويسيم . در اين متد توسط يک حلقه for each ندهای فايل را بررسی می کنيم تا ندی را بيابيم که نامش مشابه با متغير ورودی متد است . سپس با استفاده از خاصيت nodeValue می توانيم مقدار آنرا بخوانيم .


Public Function getvalue(ByVal NName As String) As String
Dim x
getvalue = ""x
For Each x In xml.documentElement.childNodes
If x.nodeName = NName Then
getvalue = x.childNodes(0).nodeValue
Exit For
End If
Next
End Function

مثالی از کار با کلاس XMLReader :
همانطور که گفته شد می توانيم پارامترهای اتصال به بانک اطلاعاتی را در فايل XML قرار دهيم و در زمان Initiate کردن ADODB برای اتصال به بانک اطلاعاتی ، آنها را بخوانيم :


Dim xmlf As New XMLReader
Call xmlf.Initiate("config.xml")x
userName = xmlf.getvalue("DataBaseID")x
Password = xmlf.getvalue("DataBasePassword")x
database_name = xmlf.getvalue("DataBaseName")x
server_name = xmlf.getvalue("ServerAddress")x

ساختار يک فايل نمونه config.xml بصورت زير می باشد :



<Application>testIt</Application>
<ServerAddress>192.168.0.1</ServerAddress>
<DataBaseName>Edatabase</DataBaseName>
<DataBaseID>Euser</DataBaseID>
<DataBasePassword>Epass</DataBasePassword>


ساير نکات برای توسعه کلاس فوق :
نکات زير شما را در نوشتن کلاسی کاملتر راهنمايي می کنند :

1 - توجه داشته باشيد که xml.documentElement بعنوان ريشه فايل xml محسوب می شود . بنابراين برای دسترسی به ريشه می توان يک شی ريشه نيز تعريف کرد :


Dim root
Set root = xml.documentElement

2 - در صورتيکه يک فايل xml دارای چندين ند در ريشه اش باشد و هر ند ريشه نيز دارای چندين ند درونی باشد توسط خاصيت root.childNodes.length و با استفاده از يک حلقه for می توان به اين ندها دسترسی داشت . برای مثال فايل زير را درنظر بگيريد :



<people>
<user>
<name>ali</name>
<id>1</id>
</user>
<user>
<name>reza</name>
<id>2</id>
</user>
</people>


حلقه زير روش دسترسی را به اين فايل نشنان می دهد :


For I = 0 TO (root.childNodes.length - 1)x
Set thisChild = root.childNodes(I)x
name = thisChild.childNodes(0).Text
id = thisChild.childNodes(1).Text
Next

3 – اضافه کردن ند به فايل : برای اضافه کردن ند از متدهای createNode و appendChild استفاده می شود برای مثال برای اضافه کردن يک user جديد به مثال فوق :


Set newuser = xml.createNode("element", "people", "")x
Dim name,id
Set newname = xml.createNode("element", "name", "")x
newname.text = yourname
Set newid = xml.createNode("element", "id", "")x
newid.text = yourid
newuser.appendChild(newname)x
newuser.appendChild(newid)x
root.appendChild(newuser)x

در انتها نيز بايستی فايل را ذخيره نمود :


xml.save(Server.Mappath(filename))x

4 – حذف يک ند از فايل : برای حذف يک ند از فايل توسط يک حلقه for بايستی ند مورد نظر را يافته و سپس توسط متد removeChild آنرا حذف کنيم :


found = False
For I = (root.childNodes.length - 1) TO 0 STEP -1
Set thisChild = root.childNodes(I)x
name = thisChild.childNodes(0).Text
If name = searchname Then
root.removeChild(thisChild)x
found = True
End If
Next

[parsiyan_mohsen]

حالا می خواهم واستون آموزش DIRECTX_GRAPHIC رو بزارم ....!!!!!!!!!!!

[parsiyan_mohsen]

آموزش DirectX-Graphic قسمت اول

DirectX8 ابزاري براي ساخت تصاوير ثابت و متحرک دو بعدي و سه بعدي مي باشد .
براي کار با DirectX8 ابتدا بايستي آنرا روي سيستم خود نصب کنيد . سپس در محيط vb از منوي project گزينه References را انتخاب کنيد . در فرمي که ظاهر مي شود اطمينان حاصل کنيد که گزينه DirectX8 for VB type library فعال باشد .
براي کار با DirectX8 بايستي از تعريف نمودن شي پايه DirectX8 شروع نمود :



Dim Dx as DirectX8

شي Direct3D8 براي کنترل اشيا‌‌ سه بعدي بکار مي رود :



Dim D3D as Direct3D8

شي Direct3DDevice8 ، سخت افزار مربوط به رندر تصاوير را مشخص مي کند :



Dim D3DDevice as Direct3DDevice8

حال براي شروع کار با Direct3D ، تابع ( ) initialise را تعريف مي کنيم . اگر اينکار درست انجام شود تابع ، مقدار true را برمي گرداند :



public function initialise () as boolean
Dim DispMode as D3DISPLAYMODE

شي D3DISPLAYMODE حالت نمايش را مشخص مي نمايد .



Dim D3Dwindow as D3DPRESENT_PARAMETERS

شي فوق مشخص مي کند که viewport شما چگونه باشد .
حال شي اصلي DirectX8 را مي سازيم :



Set Dx=New DirectX8

سپس شي اصلي ساخت واسط سه بعدي را مي سازيم :



()set D3D.Dx.Direct3Dcreate

سپس حالت فعلي نمايش را با دستور زير استخراج مي کنيم :



D3D.getadapterdisplaymode D3DADAPTER_DEFAULT,dispmode

حال دو حالت براي کار با DirectX داريم :
1 - windowed mode
2 - fullscrean mode
1 - براي کار با حالت پنجره اي ابتدا اين موضوع را به DirectX اطلاع مي دهيم :



D3Dwindow.windowed=1

سپس نوع referesh تصوير را مشخص مي کنيم ( در اينجا چند انتخاب وجود دارد که در صورت نياز به اطلاعات بيشتر با من (sheidaian@yahoo.com) تماس بگيريد . ) :



D3Dwindow.swapeffect=D3DSWAPEFFECT_COPY_VSYNC

سپس بايستي فرمت بافر نگهدارنده تصاوير را مشخص کنيم :



D3Dwindow.backbufferformat=dispmode.format

2 - براي کار با حالت تمام صفحه ، ابتدا نوع refresh را مشخص کرده سپس تعداد بافر هاي تصوير و سرانجام نوع و سايز بافر را مشخص مي نمائيم :



D3Dwindow.swapeffect=D3DSWAPEFFECT_DISCARD
D3Dwindow.backbuffercount=1
D3Dwindow.backbufferformat=dispmode.format
D3Dwindow.backbufferheight=dispmode.height
D3Dwindow.backbufferwidth=dispmode.width

سپس پنجره نمايش مشخص مي گردد :



D3Dwindow.hdevicewindow=frmMain.hwnd


@حال بايستی يک device ساخته شود که يا از طريق سخت افزار و يا نرم افزار تصاوير را رندر نمايد :



Set D3DDevice=D3Dcreatedevice(D3DADAPTER_DEFAULT
,D3DDEVTYPE_HAL,
frmMain.hwnd,D3DCREATE_SOFTWARE_VERTEXPROCESSING,
D3Dwindow)x,
end sub

درصورتي که کارت گرافيک شما امکانات رندر سخت افزاري تصاوير را ندارد از D3DDEVTYPE_REF بجاي D3DDEVTYPE_HAL استفاده کنيد .
حال بايستي روتين render را بنويسيم . البته در اين درس تصويري براي رندر نداريم و تنها چگونگي نوشتن اين روتين را بيان خواهم کرد :
۱ - ابتدا بايستي device مربوط به رندر ، قبل از کشيدن تصوير در آن پاک شود :



D3DDevice.clear 0,byval 0,D3DCLEAR_TARGET,&H0,1#,0

عدد hex اي که در دستور فوق آمده رنگ زمينه صفحه را مشخص مي کند
۲ - سپس بايستي تصاوير مورد نظر را رندر کنيم . اينکار توسط دستورات زير انجام مي شود :



D3DDevice.beginscence
all rendering calls go between these two lines '
D3DDEvice.endscence

3 - در پايان بايستي صفحه را update کنيد :



D3DDevice.present byval 0,byval 0,0,byval 0

[parsiyan_mohsen]

آموزش DirectX-Graphic قسمت دوم
موضوع : بدست آوردن مشخصات و تواناييهاي گرافيکي يک سيستم توسط DirectX-Graphic


1 - شمارش تعداد آداپتورهاي گرافيکي يک سيستم : فرض کنيد متغير nAdapters متغيري از نوع long باشد . همچنين شي D3DADAPTER_IDENTIFIER8 يک ساختار است که اطلاعات مربوط به آداپتور را نگه مي دارد . در اينصورت روتين enumerateAdapters بصورت زير خواهد بود :


Dim adapterinfo as D3DADAPTER_IDENTIFIER8
Private Sub EnumerateAdapters
Dim i as integer
nadapters=D3D.Getadaptercount


براي بدست آوردن جزئيات آداپبورها بصورت زير عمل مي کنيم :


for i=0 to nadapters-1
D3D.GetadapterIdentifier i ,0,adapterinfo


نام اين آداپتور بصورت ليستي از کدهاي اسکي است که بايستي آنها را درون يک string قرار دهيم :


for j=0 to 511
name=name & chr$(adapterinfo.description(j)) x
next j
name=replace(name,chr$(0)," ") x
end sub


بنابراين در متغير name نام آداپتور قرار خواهد گرفت .

۲ - مشخص کردن نوع Rendering : فرض کنيد شي D3DCAPS8 توانايي rendering آداپتور را نشان دهد . در اينصورت روتين EnumerateDevices بصورت زير خواهد بود :


Private EnumerateDevices
On Local Error resume next
Dim Caps as D3DCAPS8
deviceindex=0 'For Example
D3D.Getdevicecaps deviceindex,D3DDEVTYPE_HAL,caps
if err.number=D3DERR_NOTAVAILABLE then


اگر آداپتور امکان رندر سخت افزاري نداشته باشد در اينصورت :


MsgBox("Reference Rasterizer(REF)") x
else
MsgBox("Hardware Acceleration(HAL)+Reference Rasterizer(REF)") x
end if
end sub


3 - شمارش تعداد Mode نمايشي آداپتور :
فرض کنيد در صورت REF بودن امکان رندر ، متغير r=2 و در غيراينصورت r=1
باشد . همچنين شي D3DDISPLAYMODE اطلاعات مدهاي نمايشي را در خود
دارد . همچنين فرض کنيد متغير nModes از نوع longباشد . در اينصورت روتين enumeratedispmodes بصورت زير خواهد بود :


Private Sub EnumerateDispModes(r as Long,n as Long) x
Dim i as integer
Dim mode_tmp as D3DDISPLAYMODE
deviceindex=0 'For Example
nModes=D3D.Getadaptermodecount(deviceindex) x
for i=0 to nModes-1
D3D.EnumAdapterModes(deviceindex,i,mode_tmp) x


ابتدا Mode ها را به دو گروه ۱۶ بيتي و ۳۲ بيتي تقسيم مي کنيم :


if mode_tmp.format=D3DFMT_R8G8B8 or mode_tmp=D3DFMT_X8R8G8B8 or mode_tmp=D3DFMT_A8R8G8B8 then


حال چک مي کنيم که device قابل پذيرش و معتبر است يا نه :


if D3D.checkdevicetype(deviceindex,r,mode_tmp.format, mode_tmp.format,Flase)>=0 then
MsgBox(mode_tmp.width & "X" & mode_tmp.height & "32 Bit
FMT:" & mode_tmp.format ) x & "
end if
else
if D3D.checkdevicetype(deviceindex,r,mode_tmp.format, mode_tmp.format,Flase)>=0 then
MsgBox(mode_tmp.width & "X" & mode_tmp.height & "16 Bit
FMT:" & mode_tmp.format ) x & "
end if
end if
next i


4 - مشخص کردن توانايي هاي آداپتور گرافيکي : فرض کنيد در صورت REF بودن امکان رندر ، متغير r=2 و در غيراينصورت r=1 باشد :


Private Sub EnumerateHardware(r as long) x
Dim caps as D3DCAPS8
D3D.Getdevicecaps deviceindex,r,caps
If Caps.MaxActiveLights = -1 Then
MsgBox "Maximum Active Lights: Unlimited" x
Else
MsgBox "Maximum Active Lights: " & Caps.MaxActiveLights
End If
MsgBox "Maximum Point Vertex size: " & Caps.MaxPointSize
MsgBox "Maximum Texture Size: " & Caps.MaxTextureWidth & "X" & Caps.MaxTextureHeight
MsgBox "Maximum Primatives in one call: " & Caps.MaxPrimitiveCount
If Caps.TextureCaps And D3DPTEXTURECAPS_SQUAREONLY Then
MsgBox "Textures must always be square" x
End If
If Caps.TextureCaps And D3DPTEXTURECAPS_CUBEMAP Then
MsgBox "Device Supports Cube Mapping" x
End If
If Caps.TextureCaps And D3DPTEXTURECAPS_VOLUMEMAP Then
MsgBox "Device Supports Volume Mapping" x
End If
If Caps.DevCaps And D3DDEVCAPS_PUREDEVICE Then
MsgBox "Device supports the Pure Device Option" x
End If
If Caps.DevCaps And D3DDEVCAPS_HWTRANSFORMANDLIGHT Then
MsgBox "Device supports hardware transform and lighting" x
End If
If Caps.DevCaps And D3DDEVCAPS_HWRASTERIZATION Then
MsgBox "Device can use Hardware Rasterization" x
End If
If Caps.Caps2 And D3DCAPS2_CANCALIBRATEGAMMA Then
MsgBox "Device can Calibrate Gamma" x
End If
If Caps.Caps2 And D3DCAPS2_CANRENDERWINDOWED Then
MsgBox "Device can Render in Windowed Mode" x
End If
If Caps.Caps2 And D3DCAPS2_FULLSCREENGAMMA Then
MsgBox "Device can calibrate gamma in fullscreen mode" x
End If
If Caps.RasterCaps And D3DPRASTERCAPS_FOGRANGE Then
MsgBox "Device supports range based fog calculations" x
End If
If Caps.RasterCaps And D3DPRASTERCAPS_ANISOTROPY Then
MsgBox "Device supports Anisotropic Filtering" x
End If
If Caps.RasterCaps And D3DPRASTERCAPS_ZBUFFERLESSHSR Then
MsgBox "Device does not require a Z-Buffer/Depth Buffer" x
End If

[parsiyan_mohsen]

آموزش DirectX-Graphic قسمت سوم
موضوع : رسم اشکال دو بعدي

مروري بر object هاي DirectX8
1 - DirectX8 : اين شي ، شي مرکزي براي directX است و به شما امکان دسترسي به توابع و اشيا DirectX را مي دهد .
۲ - Direct3D8 : شي اصلي براي کار با محيط سه بعدي مي باشد . هدف از آن ، ساخت Direct3DDevice8 است و همچنين شامل توابعي براي مشخص کردن توانايي هاي کارت گرافيک است .
۳ - Direct3DDevice8 : اين شي مسئول ساخت بافتها textures ، مديريت نورها در يک صحنه ، مديريت مواد materials و همچنين render صحنه است . در واقع اين شي ، قلب نمايشي کار شماست .
4 - D3DX8 : گر چه هميشه نيازي به استفاده از اين شي نيست ، اما اين شي شامل توابعي براي ساخت برنامه هاي userfriendly تر توسط DirectX است . مثلاً ساخت اشيا سه بعدي ( مثل کره ، مکعب و ... ) ، ساخت بافتها ، ساخت سطوح و غيره
شروع کار براي رسم اشيا دوبعدي
ابتدا ثابت FVF را تعريف مي کنيم . اين ثابت توصيف " فرمت قابل انعطاف نقطه flexible-vertex-format " براي يک vertex دو بعدي انتقال يافته و ساده شده مي باشد .
سپس بايستي يک ساختار براي توصيف اين vertex معرفي کنيم :


Const FVF = D3DFVF_XYZRHW Or D3DFVF_TEX1 Or D3DFVF_DIFFUSE Or D3DFVF_SPECULAR
Private Type TLVERTEX
X As Single
Y As Single
Z As Single
rhw As Single
color As Long
specular As Long
tu As Single
tv As Single
End Type


فرض کنيد بخواهيم يک مربع را در صفحه رسم کنيم . براي رسم آن نياز به 4 عدد vertex داريم . بنابراين آرايه TriStrip را از نوع TLVERTEX تعريف ميکنيم :


Dim TriStrip (0 To 3) As TLVERTEX


حال به سراغ تابع initialize که در درس ۱ با آن آشنا شديد مي رويم و دستورات زير را به آن اضافه مي کنيم :


Private Function Initialize as boolean
.
.
.


ابتدا سيستم سايه زني vertex را طوري تنظيم مي کنيم که از FVF استفاده کند .


D3DDevice.SetVertexShader FVF


حال سيستم lighting را براي vertex هاي دو بعدي غير فعال مي کنيم زيرا نيازي به آن نداريم :


D3DDevice.SetRenderState D3DRS_LIGHTING,false


حال بايستي تابع initializeGeometry را اجرا کنيم . اين تابع را در ادامه توضيح خواهم داد . اگر نتيجه اين تابع true باشد دراينصورت initialize به درستي انجام شده است :


if initializeGeometry()=true then initialize=true
end function


تابع initializeGeometry در اين درس ، تابعي ساده است که تنها آرايه Vertex ها را مقدار دهي مي کند . براي رسم يک مربع نياز به مقداردهي ۴ vertex در جهت عقربه هاي ساعت داريم ( اين مربع شامل ۲ مثلث است )



Private Function InitialiseGeometry() As Boolean
On Error GoTo BOut:
color = RGB(200, 100, 0)
TriStrip(0) = CreateTLVertex(100, 100, 0, 1, color, 0, 0, 0)
TriStrip(1) = CreateTLVertex(300, 100, 0, 1, color, 0, 0, 0)
TriStrip(2) = CreateTLVertex(100, 300, 0, 1, color, 0, 0, 0)
TriStrip(3) = CreateTLVertex(300, 300, 0, 1, color, 0, 0, 0)
InitialiseGeometry = True
Exit Function
BOut:
InitialiseGeometry = False
End Function


همانطور که مشاهده مي کنيد براي تعريف vertex از تابع CreateTLVERTEX استفاده شده است . اين تابع صرفاً مقادير ساختار TLVERTEX را مقداردهي مي کند :


Private Function CreateTLVertex(X As Single, Y As Single, Z As Single, rhw As Single, color As Long, specular As Long, tu As Single, tv As Single) As TLVERTEX


نکته : ضمن اينکه شما مي توانيد مقادير اعشاري floating point را براي مختصاتهاي x و y و z بکار ببريد ، Direct3D مختصاتها را با گردکردن آنها تخمين مي زند و بنابراين ممکنست باعث ايجاد نتايج ناخواسته شود .


CreateTLVertex.X = X
CreateTLVertex.Y = Y
CreateTLVertex.Z = Z
CreateTLVertex.rhw = rhw
CreateTLVertex.color = color
CreateTLVertex.specular = specular
CreateTLVertex.tu = tu
CreateTLVertex.tv = tv
End Function
حال بايستي تابع Render را بنويسيم :
Public Sub Render()
D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET, 0, 1#, 0
D3DDevice.BeginScene
D3DDevice.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, TriStrip(0), Len(TriStrip(0))x
D3DDevice.EndScene
D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub


ساختار اصلي براي اجراي توابع فوق بصورت زير است :


--Main part--
Initialize
Do While yourevent=true
Render
DoEvents
Loop

[parsiyan_mohsen]

آموزشDirectX-Graphic قسمت چهارم
موضوع : آشنايي با برخي اصطلاحات

1- Mesh : مش ، مجموعه اي از face ها است که يک شي سه بعدي را روي صفحه تشکيل مي دهند .

۲ - Face : يک چند ضلعی است که توسط مجموعه ای از نقاط به نام vertex ساخته مي شود .

۳ - Vertex : يک نقطه در فضاي سه بعدي است که براي دادن موقعيت ، scale و زاويه يک face استفاده مي شود .

۴ - Direct3D از شيي بنام D3DVERTEX براي نمايش يک Vertex استفاده مي کند . براي ساخت face نيز از آرايه اي از vertex ها استفاده مي شود . آرايه هميشه بايستي قابل تقسيم به سه باشد زيرا اشکال از face هاي مثلثي ساخته مي شوند . هنگاميکه اين مثلثها کنار هم گذاشته شوند ، شي سه بعدي را مي سازند . Direct3D از بافري با نام Index Buffer استفاده مي کند که با direct3D مي گويد که با چه ترتيبي vertex ها را رسم نمايد . index ها بايستي هميشه در جهت عقربه هاي ساعت مشخص شوند .

[parsiyan_mohsen]

آموزشDirectX-Graphic قسمت پنجم
موضوع : اختصاص بافت Texture به اشکال دو بعدي

در اين درس مي خواهيم يک مربع که داراي بافت مي باشد را رسم کنيم . براي اينکار از کتابخانه کمکي D3DX8 استفاده مي کنيم . همچنين شي Direct3DTexture8 را نيز استفاده مي نمائيم .


Dim D3DX as D3DX8
Dim Texture as Direct3DTexture8


حال بايستي در تابع Initialize بافت مربوطه را از روي يک فايل تصويري load کنيم :


Private Function Initialize as boolean
.
.
.
Set Texture=D3DX8.CreateTextureFromFile(D3DDevice,app. path & yourfilename) x
end function


تابع Render نيز بصورت زير خواهد بود :


Private Sub Render
D3DDevice.clear 0,byval 0,D3DCLEAR_TARGET,0,1#,0
D3DDevice.beginscence
D3DDevice.SetTexture 0,Texture
D3DDevice.DrawprimitiveUP D3DPT_TRIANGLESTRIP,2,Tripstrip(0),len(Tristrip(0) )x
.
.
.
end function

[parsiyan_mohsen]

آموزشDirectX-Graphic قسمت ششم
موضوع : مفاهيم اوليه رسم اشکال سه بعدي در DirectX 8

در اين درس با استفاده از Direct3D يک مکعب را رسم مي کنيم . براي اين منظور ابتدا نياز به يک بافر داريم که بتوانيم شکل مورد نظر خود را در آن ذخيره کنيم :


Dim VBuffer as Direct3DVertexBuffer8


براي رسم مکعب از vertex هاي سه بعدي استفاده مي کنيم . براي اينکار نياز به تعريف يک تايپ جديد داريم :


Private Type LITVERTEX
x as single
y as single
z as single
color as long
specular as long
tu as single
tv as single
end type


توصيف گر اين فرمت ، بصورت زير است :


Const Lit_FVF = (D3DFVF_XYZ Or D3DFVF_DIFFUSE Or D3DFVF_SPECULAR Or D3DFVF_TEX1)x


براي توصيف مکعب در اين درس از روشي غيرکارامد استفاده شده است . به اين ترتيب که از ۳۶ عدد vertex استفاده شده ( در درسهاي بعدي متدهايي معرفي خواهند شد که اجازه مي دهند از ۸ عدد vertex باري توصيف مکعب استفاده کنيد ) .


Dim cube(35) as LITVERTEX


سپس بايد يکسري ماتريس سه بعدي تعريف کنيم :
اولين ماتريس ، matworld است که نشان مي دهد چگونه vertex ها در فضاي سه بعدي قرار گرفته اند . دومين ماتريس ، matview است که نشان مي دهد دوربين ( نقطه ديد ) در کجا قرار گرفته و سومين ماتريس ، matproj است که نشان مي دهد دوربين چگونه دنياي سه بعدي را روي صفحه دو بعدي نشان مي دهد :


Dim matworld as D3DMATRIX
Dim matview as D3DMATRIX
Dim matproj as D3DMATRIX


در تابع Initialize قبل از ساخت device بايستي چک کنيم که آيا مي توانيم از يک بافر Z شانزده بيتي استفاده کنيم يا نه ؟


If D3D.CheckDeviceFormat(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, DispMode.Format, D3DUSAGE_DEPTHSTENCIL, D3DRTYPE_SURFACE, D3DFMT_D16) = D3D_OK Then
D3DWindow.AutoDepthStencilFormat = D3DFMT_D16 '16 bit Z-Buffer


حال بايستي متد D3DCreateDevice را اجرا کنيد . سپس بايد سيستم سايه زني vertex را با فرمت vertex مان تنظيم کنيم :


D3DDevice.SetVertexShader Lit_FVF


همچنين سيستم نورپردازي را غير فعال مي کنيم :


D3DDevice.SetRenderState D3DRS_LIGHTING, False


Direct3D هيچ مثلثي را که در ديد شما نباشد رسم نخواهد کرد . براي متوقف کردن اين امر بايستي حالت culling آنرا متوقف کنيد همچنين vertex ها را بترتيب عقربه هاي ساعت معرفي کنيد :


D3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE


سپس بايد فرمت بافر Z را فعال سازيد :


D3DDevice.SetRenderState D3DRS_ZENABLE, 1

[parsiyan_mohsen]

آموزشDirectX-Graphic قسمت هفتم
تعريف ماترسها

1 - World Matrix : اين ماتريس براي نگهداري تمام vertex هايي که براي رندر فرستاده مي شوند بکار مي رود . مقادير موجود در اين ماتريس ، موقعيت يک vertex را مي تواند تغيير دهد . يکي از کاربردهاي آن انجام دورانrotation ، انتقال transmittion و تغییر اندازه scaling است .
برای ساخت اين ماتريس از دستور زير استفاده می کنيم :


D3DXMatrixIdentify matworld


حال اين ماتريس را براي device مربوطه تاييد مي کنيم :


D3DDevice.SetTransform D3DTS_WORLD,matworld


۲ - View Matrix : اين ماتريس را بعنوان يک دوربين در نظر بگيريد که بوسيله يک نقطه شروع و يک نقطه پاياني مشخص مي شود ( مشابه يک up vector که معمولاً در طول محور y رو به بالاست ) :


D3DXMatrixLookAtLH matView, MakeV(0, 5, 9), MakeV(0, 0, 0),MakeV(0, 1, 0) x
D3DDevice.SetTransform D3DTS_VIEW, matView


تابع MakeV که در اينجا استفاده شده بصورت زير است :


Private Function MakeV(x As Single, y As Single, z As Single) As D3DVECTOR
MakeV.x = x
MakeV.y = y
MakeV.z = z
End Function


۳ - Projection Matrix : اين ماتريس مشخص مي کند چه منطقه اي از فضاي جهاني براي رندر کردن visible باشد . همچنين مشخص مي کند چه مقدار مي توانيم بطور افقي ببينيم ( زاويه ديد بزرگتر منجر به ديد بزرگتر مي شود ) :


D3DXMatrixPerspectiveFovLH matProj, pi / 4, 1, 0.1, 500


در دستور فوق از زاويه ديد pi/4 راديان استفاده شده همچنين نسبت 1:1 استفاده شده است . قسمتهاي سوم و چهارم مشخص مي کنند فقط مثلثهايي کشيده شوند که با ابعاد بزرگتر از يکدهم دوربين و کوچکتر از ۵۰۰ برابر دوربين هستند .
حال دستور اختصاص به device را خواهيم داشت :


D3DDevice.SetTransform D3DTS_PROJECTION, matProj


بعد از تعريف ماتريسها بايستي تابع InitializeGeometry را صدا کنيم . در اين تابع از يک ثابت با نام DFC استفاده شده است . اگر DFC=1 باشد مکعب بطور کامل کشيده مي شود و اگر بزرگتر از يک باشد ، face هاي آن جدا از هم ديده خواهند شد . همچنين توجه کنيد که از بافرهاي vertex براي ذخيره داده vertex ها استفاده شده است . ساختار اين تابع بصورت زير خواهد بود :
۱ - پر کردن ساختارهاي vertex


'Front
Cube(0) = CreateLitVertex(-1, 1, DFC, color, 0, 0, 0)x
Cube(1) = CreateLitVertex(1, 1, DFC, color, 0, 0, 0)x
Cube(2) = CreateLitVertex(-1, -1, DFCcolor, 0, 0, 0)x
Cube(4) = CreateLitVertex(-1, -1, DFC, color, 0, 0, 0)x
Cube(5) = CreateLitVertex(1, -1, DFC, color, 0, 0, 0)x
'Back
Cube(6) = CreateLitVertex(-1, 1, -DFC, color, 0, 0, 0)x
Cube(7) = CreateLitVertex(1, 1, -DFC, color, 0, 0, 0)x
Cube(8) = CreateLitVertex(-1, -1, -DFC, color, 0, 0, 0)x
Cube(9) = CreateLitVertex(1, 1, -DFC, color, 0, 0, 0)x
Cube(10) = CreateLitVertex(-1, -1, -DFC, color, 0, 0, 0)x
Cube(11) = CreateLitVertex(1, -1, -DFC, color, 0, 0, 0)x
'Right
Cube(12) = CreateLitVertex(-DFC, 1, -1, color, 0, 0, 0)x
Cube(13) = CreateLitVertex(-DFC, 1, 1, color, 0, 0, 0)x
Cube(14) = CreateLitVertex(-DFC, -1, -1, color, 0, 0, 0)x
Cube(15) = CreateLitVertex(-DFC, 1, 1, color, 0, 0, 0)x
Cube(16) = CreateLitVertex(-DFC, -1, -1, color, 0, 0, 0)x
Cube(17) = CreateLitVertex(-DFC, -1, 1, color, 0, 0, 0)x
'Left
Cube(18) = CreateLitVertex(DFC, 1, -1, color, 0, 0, 0)x
Cube(20) = CreateLitVertex(DFC, -1, -1, color, 0, 0, 0)x
Cube(21) = CreateLitVertex(DFC, 1, 1, color, 0, 0, 0)x
Cube(22) = CreateLitVertex(DFC, -1, -1, color, 0, 0, 0)x
Cube(23) = CreateLitVertex(DFC, -1, 1, color, 0, 0, 0)x
'Top
Cube(24) = CreateLitVertex(-1, DFC, 1, color, 0, 0, 0)x
Cube(25) = CreateLitVertex(1, DFC, 1, color, 0, 0, 0)x
Cube(26) = CreateLitVertex(-1, DFC, -1, color, 0, 0, 0)x
Cube(27) = CreateLitVertex(1, DFC, 1, cocolor, 0, 0, 0)x
Cube(29) = CreateLitVertex(1, DFC, -1, color, 0, 0, 0)x
'Bottom
Cube(30) = CreateLitVertex(-1, -DFC, 1, color, 0, 0, 0)x
Cube(31) = CreateLitVertex(1, -DFC, 1, color, 0, 0, 0)x
Cube(32) = CreateLitVertex(-1, -DFC, -1, color, 0, 0, 0)x
Cube(33) = CreateLitVertex(1, -DFC, 1, color, 0, 0, 0)x
Cube(34) = CreateLitVertex(-1, -DFC, -1, color, 0, 0, 0)x
Cube(35) = CreateLitVertex(1, -DFC, -1, color, 0, 0, 0)x


2 - ساخت يک بافر vertex خالي با سايز مورد نظر :


Set VBuffer = D3DDevice.CreateVertexBuffer(Len(Cube(0)) * 36, 0, Lit_FVF, D3DPOOL_DEFAULT)x


3 - پر کردن بافر مربوطه با داده ها :


D3DVertexBuffer8SetData VBuffer, 0, Len(Cube(0)) * 36, 0, Cube(0)x


حال به سراغ روتين Render مي رويم :


Public Sub Render
D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, 0, 1#, 0 '//Clear the screen black
D3DDevice.BeginScene
D3DDevice.SetStreamSource 0, VBuffer, Len(Cube(0))x
D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, 12
D3DDevice.EndScene
D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub


ساختار اصلي برنامه بصورت زير خواهد بود :


Dim RotateAngle As Single
Dim matTemp As D3DMATRIX '//To hold temporary
call Initialize
Do While bRunning
RotateAngle = RotateAngle + 0.1
If RotateAngle >= 360 Then RotateAngle = RotateAngle - 360
D3DXMatrixIdentity matWorld '//Reset our world matrix
D3DXMatrixIdentity matTemp
D3DXMatrixRotationX matTemp, RotateAngle * (pi / 180) x
D3DXMatrixMultiply matWorld, matWorld, matTemp
D3DXMatrixIdentity matTemp
D3DXMatrixRotationZ matTemp, RotateAngle * (pi / 180) x
D3DXMatrixMultiply matWorld, matWorld, matTemp
D3DDevice.SetTransform D3DTS_WORLD, matWorld
Render
DoEvents
Loop

[parsiyan_mohsen]

آموزشDirectX-Graphic قسمت هشتم
موضوع : نورپردازي و اختصاص بافت به اشيا سه بعدي
در اين درس مي خواهيم به مکعب درس قبل بافت اختصاص داده و نيز آنرا با يک منبع نور ، نورپردازي کنيم .
ابتدا تايپ vertex ها را بصورت زير تعريف مي کنيم :


Private Type UnlitVertex
X As Single
Y As Single
Z As Single
nx As Single
ny As Single
nz As Single
tu As Single
tv As Single
End Type


توصيفگر اين فرمت بصورت زير خواهد بود :


Const Unlit_FVF = (D3DFVF_XYZ Or D3DFVF_NORMAL Or D3DFVF_TEX1)


همچنين مکعب ما توسط ارايه زير مشخص مي شود :


Dim Cube2(35) As UnlitVertex


دو ثابت pi و rad را نيز بصورت زير تعريف مي کنيم :


Const pi As Single = 3.141592
Const Rad = pi / 180


براي اختصاص بافت به مکعب ، از شي Direct3DTexture8 استفاده مي شود :


Dim CubeTexture As Direct3DTexture8


براي نورپردازي ، از شي D3DLIGHT8 استفاده مي شود :


Dim Lights As D3DLIGHT8



تغييرات مورد نياز در تابع Initialize
بعد از ساخت شي D3DDevice در اين تابع ، پارامترهاي آنرا بصورت زير تنظيم مي کنيم :


D3DDevice.SetVertexShader Unlit_FVF
D3DDevice.SetRenderState D3DRS_LIGHTING, 1
D3DDevice.SetRenderState D3DRS_ZENABLE, 1
D3DDevice.SetRenderState D3DRS_AMBIENT, &H202020


مقدار ambient يک کد هگزا RRGGBB است .
بعد از دستورات فوق ماتريسهاي matworld ، matview و matproj مطابق مطابل درس قبل تعريف مي شوند . پس از آن بايستي بافت مکعب را از درون فايل تصويري مورد نظرتان load کنيد :


Set CubeTexture = D3DX.CreateTextureFromFileEx(D3DDevice, yourfilename, 128, 128, D3DX_DEFAULT, 0, DispMode.Format, D3DPOOL_MANAGED, D3DX_FILTER_LINEAR, D3DX_FILTER_LINEAR, 0, ByVal 0, ByVal 0)x


حال بايستي تابع InitializeGeometry صدا زده شود و سپس تابع SetupLights فراخواني شوند . ابتدا به توضيح تابع InitializeGeometry مي پردازيم :


Private Function InitialiseGeometry() As Boolean


ابتدا يک بردار نرمال تعريف مي کنيم :


Dim vN As D3DVECTOR


سپس آرايه cube2 را با مقادير عددي پر مي کنيم . نرمالهاي تمام vertex ها را ابتدا با بردار
[0,0,0 ] تعريف مي کنيم . اين مقدا بعداً تغيير خواهد کرد :


Cube2(0) = CreateVertex(-1, -1, 1, 0, 0, 0, 0, 0)
Cube2(1) = CreateVertex(1, 1, 1, 0, 0, 0, 1, 1)
Cube2(2) = CreateVertex(-1, 1, 1, 0, 0, 0, 0, 1)
vN = GenerateTriangleNormals(Cube2(0), Cube2(1), Cube2(2))
Cube2(0).nx = vN.X: Cube2(0).ny = vN.Y: Cube2(0).nz = vN.Z
Cube2(1).nx = vN.X: Cube2(1).ny = vN.Y: Cube2(1).nz = vN.Z
Cube2(2).nx = vN.X: Cube2(2).ny = vN.Y: Cube2(2).nz = vN.Z


Cube2(3) = CreateVertex(1, 1, 1, 0, 0, 0, 1, 1)
Cube2(4) = CreateVertex(-1, -1, 1, 0, 0, 0, 0, 0)
Cube2(5) = CreateVertex(1, -1, 1, 0, 0, 0, 1, 0)
vN = GenerateTriangleNormals(Cube2(3), Cube2(4), Cube2(5))
Cube2(3).nx = vN.X: Cube2(3).ny = vN.Y: Cube2(3).nz = vN.Z
Cube2(4).nx = vN.X: Cube2(4).ny = vN.Y: Cube2(4).nz = vN.Z
Cube2(5).nx = vN.X: Cube2(5).ny = vN.Y: Cube2(5).nz = vN.Z

'Back
Cube2(6) = CreateVertex(-1, 1, -1, 0, 0, 0, 0, 1)
Cube2(7) = CreateVertex(1, 1, -1, 0, 0, 0, 1, 1)
Cube2(8) = CreateVertex(-1, -1, -1, 0, 0, 0, 0, 0)
vN = GenerateTriangleNormals(Cube2(6), Cube2(7), Cube2(8))
Cube2(6).nx = vN.X: Cube2(6).ny = vN.Y: Cube2(6).nz = vN.Z
Cube2(7).nx = vN.X: Cube2(7).ny = vN.Y: Cube2(7).nz = vN.Z
Cube2(8).nx = vN.X: Cube2(8).ny = vN.Y: Cube2(8).nz = vN.Z

Cube2(9) = CreateVertex(1, -1, -1, 0, 0, 0, 1, 0)
Cube2(10) = CreateVertex(-1, -1, -1, 0, 0, 0, 0, 0)
Cube2(11) = CreateVertex(1, 1, -1, 0, 0, 0, 1, 1)
vN = GenerateTriangleNormals(Cube2(9), Cube2(10), Cube2(11))
Cube2(9).nx = vN.X: Cube2(9).ny = vN.Y: Cube2(9).nz = vN.Z
Cube2(10).nx = vN.X: Cube2(10).ny = vN.Y: Cube2(10).nz = vN.Z
Cube2(11).nx = vN.X: Cube2(11).ny = vN.Y: Cube2(11).nz = vN.Z

'Right
Cube2(12) = CreateVertex(-1, -1, -1, 0, 0, 0, 0, 0)
Cube2(13) = CreateVertex(-1, 1, 1, 0, 0, 0, 1, 1)
Cube2(14) = CreateVertex(-1, 1, -1, 0, 0, 0, 1, 0)
vN = GenerateTriangleNormals(Cube2(12), Cube2(13), Cube2(14))
Cube2(12).nx = vN.X: Cube2(12).ny = vN.Y: Cube2(12).nz = vN.Z
Cube2(13).nx = vN.X: Cube2(13).ny = vN.Y: Cube2(13).nz = vN.Z
Cube2(14).nx = vN.X: Cube2(14).ny = vN.Y: Cube2(14).nz = vN.Z

Cube2(15) = CreateVertex(-1, 1, 1, 0, 0, 0, 1, 1)
Cube2(16) = CreateVertex(-1, -1, -1, 0, 0, 0, 0, 0)
Cube2(17) = CreateVertex(-1, -1, 1, 0, 0, 0, 0, 1)
vN = GenerateTriangleNormals(Cube2(15), Cube2(16), Cube2(17))
Cube2(15).nx = vN.X: Cube2(15).ny = vN.Y: Cube2(15).nz = vN.Z
Cube2(16).nx = vN.X: Cube2(16).ny = vN.Y: Cube2(16).nz = vN.Z
Cube2(17).nx = vN.X: Cube2(17).ny = vN.Y: Cube2(17).nz = vN.Z

'Left
Cube2(18) = CreateVertex(1, 1, -1, 0, 0, 0, 1, 0)
Cube2(19) = CreateVertex(1, 1, 1, 0, 0, 0, 1, 1)
Cube2(20) = CreateVertex(1, -1, -1, 0, 0, 0, 0, 0)
vN = GenerateTriangleNormals(Cube2(18), Cube2(19), Cube2(20))
Cube2(18).nx = vN.X: Cube2(18).ny = vN.Y: Cube2(18).nz = vN.Z
Cube2(19).nx = vN.X: Cube2(19).ny = vN.Y: Cube2(19).nz = vN.Z
Cube2(20).nx = vN.X: Cube2(20).ny = vN.Y: Cube2(20).nz = vN.Z

Cube2(21) = CreateVertex(1, -1, 1, 0, 0, 0, 0, 1)
Cube2(22) = CreateVertex(1, -1, -1, 0, 0, 0, 0, 0)
Cube2(23) = CreateVertex(1, 1, 1, 0, 0, 0, 1, 1)
vN = GenerateTriangleNormals(Cube2(21), Cube2(22), Cube2(23))
Cube2(21).nx = vN.X: Cube2(21).ny = vN.Y: Cube2(21).nz = vN.Z
Cube2(22).nx = vN.X: Cube2(22).ny = vN.Y: Cube2(22).nz = vN.Z
Cube2(23).nx = vN.X: Cube2(23).ny = vN.Y: Cube2(23).nz = vN.Z

'Top
Cube2(24) = CreateVertex(-1, 1, 1, 0, 0, 0, 0, 1)
Cube2(25) = CreateVertex(1, 1, 1, 0, 0, 0, 1, 1)
Cube2(26) = CreateVertex(-1, 1, -1, 0, 0, 0, 0, 0)
vN = GenerateTriangleNormals(Cube2(24), Cube2(25), Cube2(26))
Cube2(24).nx = vN.X: Cube2(24).ny = vN.Y: Cube2(24).nz = vN.Z
Cube2(25).nx = vN.X: Cube2(25).ny = vN.Y: Cube2(25).nz = vN.Z
Cube2(26).nx = vN.X: Cube2(26).ny = vN.Y: Cube2(26).nz = vN.Z

Cube2(27) = CreateVertex(1, 1, -1, 0, 0, 0, 1, 0)
Cube2(28) = CreateVertex(-1, 1, -1, 0, 0, 0, 0, 0)
Cube2(29) = CreateVertex(1, 1, 1, 0, 0, 0, 1, 1)
vN = GenerateTriangleNormals(Cube2(27), Cube2(28), Cube2(29))
Cube2(27).nx = vN.X: Cube2(27).ny = vN.Y: Cube2(27).nz = vN.Z
Cube2(28).nx = vN.X: Cube2(28).ny = vN.Y: Cube2(28).nz = vN.Z
Cube2(29).nx = vN.X: Cube2(29).ny = vN.Y: Cube2(29).nz = vN.Z

'Top
Cube2(30) = CreateVertex(-1, -1, -1, 0, 0, 0, 0, 0)
Cube2(31) = CreateVertex(1, -1, 1, 0, 0, 0, 1, 1)
Cube2(32) = CreateVertex(-1, -1, 1, 0, 0, 0, 0, 1)
vN = GenerateTriangleNormals(Cube2(30), Cube2(31), Cube2(32))
Cube2(30).nx = vN.X: Cube2(30).ny = vN.Y: Cube2(30).nz = vN.Z
Cube2(31).nx = vN.X: Cube2(31).ny = vN.Y: Cube2(31).nz = vN.Z
Cube2(32).nx = vN.X: Cube2(32).ny = vN.Y: Cube2(32).nz = vN.Z

Cube2(33) = CreateVertex(1, -1, 1, 0, 0, 0, 1, 1)
Cube2(34) = CreateVertex(-1, -1, -1, 0, 0, 0, 0, 0)
Cube2(35) = CreateVertex(1, -1, -1, 0, 0, 0, 1, 0)
vN = GenerateTriangleNormals(Cube2(33), Cube2(34), Cube2(35))
Cube2(33).nx = vN.X: Cube2(33).ny = vN.Y: Cube2(33).nz = vN.Z
Cube2(34).nx = vN.X: Cube2(34).ny = vN.Y: Cube2(34).nz = vN.Z
Cube2(35).nx = vN.X: Cube2(35).ny = vN.Y: Cube2(35).nz = vN.Z


سپس يک بافر vertex خالي با ساير موردنظر مي سازيم :


Set VBuffer = D3DDevice.CreateVertexBuffer(Len(Cube2(0)) * 36, 0, Unlit_FVF, D3DPOOL_DEFAULT)x


سپس اين بافر vertex ساخته شده را با داده هاي cube2 پر مي کنيم :


D3DVertexBuffer8SetData VBuffer, 0, Len(Cube2(0)) * 36, 0, Cube2(0)x


در دستورات فوق تابعي با نام GenerateTraingleNormals استفاده شده است . اين تابع دو بردار را از روي سه vertex داده شده با آن مي سازد و سپس ضرب برداري ايندو را حساب مي کند و سپس بردار حاصله را نرمال مي نمايد :


Private Function GenerateTriangleNormals(p0 As UnlitVertex, p1 As UnlitVertex, p2 As UnlitVertex) As D3DVECTOR
Dim v01 As D3DVECTOR 'Vector from points 0 to 1
Dim v02 As D3DVECTOR 'Vector from points 0 to 2
Dim vNorm As D3DVECTOR 'The final vector

'Create the vectors from points 0 to 1 and 0 to 2
D3DXVec3Subtract v01, MakeVector(p1.X, p1.Y, p1.Z), MakeVector(p0.X, p0.Y, p0.Z)
D3DXVec3Subtract v02, MakeVector(p2.X, p2.Y, p2.Z), MakeVector(p0.X, p0.Y, p0.Z)

'Get the cross product
D3DXVec3Cross vNorm, v01, v02

'Normalize this vector
D3DXVec3Normalize vNorm, vNorm

'Return the value
GenerateTriangleNormals.X = vNorm.X
GenerateTriangleNormals.Y = vNorm.Y
GenerateTriangleNormals.Z = vNorm.Z
End Function



حال به توضيح تابع SetupLights مي پردازيم . در اين تابع دو شي D3DMATERIAL8 و D3DCOLORVALUE استفاده شده است :


Private Function SetupLights() As Boolean
Dim Mtrl As D3DMATERIAL8, Col As D3DCOLORVALUE
Col.a = 1: Col.r = 1: Col.g = 1: Col.b = 1
Mtrl.Ambient = Col
Mtrl.diffuse = Col
D3DDevice.SetMaterial Mtrl

Lights.Type = D3DLIGHT_DIRECTIONAL
Lights.diffuse.r = 1
Lights.diffuse.g = 1
Lights.diffuse.b = 1
Lights.Direction = MakeVector(1, -1, 0)

D3DDevice.SetLight 0, Lights

SetupLights = True
End Function



تابع Render بصورت زير است :


Public Sub Render()
D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, 0, 1#, 0 '//Clear the screen black
D3DDevice.BeginScene
'Draw the cube
D3DDevice.SetTexture 0, CubeTexture
D3DDevice.SetStreamSource 0, VBuffer, Len(Cube2(0))
D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, 12
D3DDevice.EndScene
D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub



ساختار اصلي برنامه بصورت زير است :


Call Initialise
Do While bRunning
RotateAngle = RotateAngle + 0.1
If RotateAngle >= 360 Then RotateAngle = RotateAngle - 360

D3DXMatrixIdentity matWorld

D3DXMatrixIdentity matTemp
D3DXMatrixRotationX matTemp, RotateAngle * (pi / 180)
D3DXMatrixMultiply matWorld, matWorld, matTemp

D3DXMatrixIdentity matTemp
D3DXMatrixRotationY matTemp, RotateAngle * (pi / 180)
D3DXMatrixMultiply matWorld, matWorld, matTemp

D3DXMatrixIdentity matTemp
D3DXMatrixRotationZ matTemp, RotateAngle * (pi / 180)
D3DXMatrixMultiply matWorld, matWorld, matTemp


D3DDevice.SetTransform D3DTS_WORLD, matWorld

D3DDevice.LightEnable 0, 0 خاموش کردن light

D3DDevice.LightEnable 0, 1 روشن کردن light

Render
DoEvents
Loop


در متد D3DDevice.LightEnable پارامتر اول شماره منبع نور و پارمتر دوم enable بودن آنرا نشان مي دهد .

[parsiyan_mohsen]

آموزش DirectX-Graphic قسمت نهم
موضوع :‌ترسيم متن دو بعدي در DirectX

در اين درس روش ترسيم متن با دو نوع فونت را نشان خواهم داد :
براي رسم يک متن با فونت تعريف شده در سيستم از شي D3DXFont استفاده مي کنيم :


Dim MainFont as D3DXFont
Dim MainFontDesc as IFont
Dim TextRect as RECT
Dim fnt as new stdFont


در حاليکه براي ايجاد يک متن با فونت custom ابتدا يک texture تعريف مي کنيم :


Dim fntTex as Direct3DTexture8


همچنين براي ترسيم هر کاراکتر يک آرايه vertex اي را از نوع TLVERTEX تعريف مي نمائيم :


Dim vertchar(3) as TLVERTEX


حال به سراغ تابع Initialize مي رويم . در اين تابع ابتدا دستورات مربوط به ايجاد اشيا D3D و D3Dx را قرا دهيد سپس دستورات مربوط به اختصاص آداپتور و نيز ايجاد شي D3DDevice را انجام مي دهيم . حال دستورات تنظيم shader و rendering را مي آوريم :


D3DDevice.SetVertexShader TL_FVF
D3DDevice.SetRenderState D3DRS_LIGHTING, False


سپس تنظيمات پارامترهاي transparency براي rendering را انجام مي دهيم :


D3DDevice.SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA
D3DDevice.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA
D3DDevice.SetRenderState D3DRS_ALPHABLENDENABLE, True


حال بايستي textureرا طوري فيلتر کنيم که در زمان stretch شدن يا squash شدن بهتر بنظر برسد :


D3DDevice.SetTextureStageState 0, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
D3DDevice.SetTextureStageState 0, D3DTSS_MINFILTER, D3DTEXF_LINEAR


حال فيلتر Z را فعال مي کنيم :


D3DDevice.SetRenderState D3DRS_ZENABLE, 1


سپس ماتريسهاي world ، view و projection را تنظيم مي کنيم :


D3DXMatrixIdentity matWorld
D3DDevice.SetTransform D3DTS_WORLD, matWorld
D3DXMatrixLookAtLH matView, MakeVector(0, 9, -9), MakeVector(0, 0, 0), MakeVector(0, 1, 0)
D3DDevice.SetTransform D3DTS_VIEW, matView
D3DXMatrixPerspectiveFovLH matProj, pi / 4, 1, 0.1, 500
D3DDevice.SetTransform D3DTS_PROJECTION, matProj


حال به بخش تنظيم پارامترهاي فونت مي رسيم . در مورد فونت دو بعدي عادي :


fnt.Name = "Verdana"x
fnt.Size = 18
fnt.Bold = True
Set MainFontDesc = fnt
Set MainFont = D3DX.CreateFont(D3DDevice, MainFontDesc.hFont)x


و در مورد فونت custom :


Set fntTex = D3DX.CreateTextureFromFileEx(D3DDevice, yourfilename, 256, 128, D3DX_DEFAULT, 0, D3DFMT_UNKNOWN, D3DPOOL_MANAGED, D3DX_FILTER_POINT, D3DX_FILTER_POINT, &HFF00FF00, ByVal 0, ByVal 0)x
end function


روتين Render بصورت زير خواهد بود :


Public Sub Render()x
D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, 0, 1#, 0
D3DDevice.BeginScene


براي رندر متن با فونت عادي بصورت زير عمل مي کنيم :


TextRect.Top = 440
TextRect.Left = 1
TextRect.bottom = 480
TextRect.Right = 640
D3DX.DrawText MainFont, &HFFCCCCFF, "Current Frame Rate: " & FPS_Current, TextRect, DT_TOP Or DT_CENTER


براي رندر متن با فونت custom بصورت زير عمل مي کنيم :


RenderStringFromCustomFont_2D "Hamed Sheidaian", 1, 1, 16, 16
D3DDevice.EndScene
D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub


همانطور که مشاهده مي کنيد از روتيني با نام RenderStringFromCustomFont_2D استفاده شده است :


Private Sub RenderStringFromCustomFont_2D(strText As String, startX As Single, StartY As Single, Height As Integer, Width As Integer)x
Dim I As Integer
Dim CharX As Integer, CharY As Integer
Dim Char As String
Dim LinearEntry As Integer
If Len(strText) = 0 Then Exit Sub
For I = 1 To Len(strText)x


1 - ابتدا بايستي مختصات texture را انتخاب کنيم . براي اينکار بايستي هر entry را در texture جدا کنيم :


Char = Mid$(strText, I, 1)x
If Asc(Char) >= 65 And Asc(Char) <= 90 Then
LinearEntry = Asc(Char) - 65
ElseIf Asc(Char) >= 97 And Asc(Char) <= 122 Then
LinearEntry = Asc(Char) - 71
ElseIf Asc(Char) >= 48 And Asc(Char) <= 57 Then
LinearEntry = Asc(Char) + 4
ElseIf Char = " " Then
LinearEntry = 63
ElseIf Char = "." Then
LinearEntry = 62
ElseIf Char = ";" Then
LinearEntry = 66
ElseIf Char = "/" Then
LinearEntry = 64
ElseIf Char = "," Then
LinearEntry = 65
End If


بعد از مقداردهي LinearEntry بايستي مختصات grid کاراکتر را پردازش کنيم :


If LinearEntry <= 15 Then
CharY = 0
CharX = LinearEntry
End If
If LinearEntry >= 16 And LinearEntry <= 31 Then
CharY = 1
CharX = LinearEntry - 16
End If
If LinearEntry >= 32 And LinearEntry <= 47 Then
CharY = 2
CharX = LinearEntry - 32
End If
If LinearEntry >= 48 And LinearEntry <= 63 Then
CharY = 3
CharX = LinearEntry - 48
End If
If LinearEntry >= 64 And LinearEntry <= 79 Then
CharY = 4
CharX = LinearEntry - 64
End If


۲ - حال بايستي vertex هاي مورد نياز براي رسم کاراکتر را توليد کنيم :


vertChar(0) = CreateTLVertex(startX + (Width * I), StartY, 0, 1, &HFFFFF
(F,0,(1/16)*CharX,(1/8)*CharY
vertChar(1) = CreateTLVertex(startX + (Width * I) + Width, StartY, 0, 1, &HFFFFF
(F, 0,((1 / 16) * CharX) + (1 / 16), (1 / 8) * CharY
vertChar(2) = CreateTLVertex(startX + (Width * I), StartY + Height, 0, 1, &HFFFFF
((F, 0, (1 / 16) * CharX, ((1 / 8) * CharY) + (1 / 8
vertChar(3) = CreateTLVertex(startX + (Width * I) + Width, StartY + Height, 0, 1, HFFFFFF, 0, ((1 / 16) * CharX) + (1 / 16), ((1 / 8) * CharY) + (1 / 8))x


۳ - رندر vertex ها :


D3DDevice.SetTexture 0, fntTex
D3DDevice.DrawPrimitiveUP D3DPT_TRIANGLESTRIP, 2, vertChar(0), Len(vertChar(0))x
Next I
End Sub

[parsiyan_mohsen]

آموزشDirectX-Graphic قسمت دهم
موضوع : ترسيم اشيا سه بعدي با استفاده از شي Mesh
شي Mesh که جزو اشيا D3DX مي باشد امکان ترسيم اشيا سه بعدي پايه و همچنين ترسيم مش هاي custom دلخواه را به شما مي دهد . در اين درس از شي Mesh براي ترسيم يک کره ( sphere ) استفاده مي کنيم . ابتدا متغير sphere را بصورت زير تعريف کنيد :


Dim sphere as D3DXMesh


همچنين براي نورپردازي و اختصاص material به کره به متغيرهاي زير نياز داريم :


Dim d3dLight As D3DLIGHT8
Dim material As D3DMATERIAL8
Dim Col As D3DCOLORVALUE


در تابع Initial پس از ساخت اشيا D3D و D3DX و D3DDevice بايستي پارامترهاي رنگ ، نورپردازي و اختصاص ماده ( material ) به کره را بصورت زير تنظيم کنيد :


Col.a = 1
Col.b = 1
Col.g = 1
Col.r = 1
d3dLight.Type = D3DLIGHT_DIRECTIONAL
d3dLight.diffuse = Col
d3dLight.Direction = vec(-1, -1, -1)x


نورپردازي از نوع جهت دار با رنگ col و بردار جهت (1-,1-,1-) است .
نکته :
رنگ ambient رنگي است که هنگاميکه جسم در سايه باشد به خود مي گيرد . بعبارت ديگر اين رنگ را جسم وقتي که در معرض يک نور ambient باشد از خود منعکس مي کند .
رنگ diffuse رنگي است که هنگاميکه جسم در معرض نور مستقيم قرار بگيرد از خود منعکس مي کند .


material.Ambient = Col
material.diffuse = Col
d3dDevice.SetMaterial material
d3dDevice.SetLight 0, d3dLight
d3dDevice.LightEnable 0, 1


سپس بايستي پارامترهاي rendering را تنظيم کنيد :


d3dDevice.SetRenderState D3DRS_LIGHTING, 1
d3dDevice.SetRenderState D3DRS_ZENABLE, 1
d3dDevice.SetRenderState D3DRS_LIGHTING, 1
d3dDevice.SetRenderState D3DRS_ZENABLE, 1
d3dDevice.SetRenderState D3DRS_SHADEMODE, D3DSHADE_GOURAUD
d3dDevice.SetRenderState D3DRS_AMBIENT, &H202020
d3dDevice.SetTextureStageState 0, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
d3dDevice.SetTextureStageState 0, D3DTSS_MINFILTER, D3DTEXF_LINEAR


حال بايستي شي sphere را بسازيم :


Set Sphere = d3dx.CreateSphere(d3dDevice, 2, 1000, 20, Nothing)x


که ۲ شعاع کره و ۱۰۰۰ تعداد slice هايي است که کره با آن ساخته مي شود .
سپس بردارهاي نقطه ديد و مکان دوربين و رنگ زمينه را تنظيم کنيد ( viewpoint و camerapoint از نوع D3DVECTOR هستند ) .


ViewPoint = vec(0, 0, 0)
CameraPoint = vec(4, 4, 4)
BackColor = &H404040


در روتين Render ابتدا ماتريسها و بردارهاي صحنه را تنظيم مي کنيم :


D3DXMatrixIdentity matWorld
d3dDevice.SetTransform D3DTS_WORLD, matWorld
D3DXMatrixRotationY matView, Rotation
D3DXMatrixLookAtLH matTemp, CameraPoint, ViewPoint, vec(0, 1, 0)
D3DXMatrixMultiply matView, matView, matTemp
d3dDevice.SetTransform D3DTS_VIEW, matView
D3DXMatrixPerspectiveFovLH matProj, pi / 4, 1, 0.1, 500
d3dDevice.SetTransform D3DTS_PROJECTION, matProj


در پايان نيز شروع به رندر صحنه مي کنيم :


d3dDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, BackColor, 1, 0
d3dDevice.BeginScene
Sphere.DrawSubset 0
d3dDevice.EndScene
d3dDevice.Present ByVal 0, ByVal 0, 0, ByVal 0

[parsiyan_mohsen]

خودم علاقه شدیدی به مبحث های DIRECTX دارم.
واسه جمع آوری اینها زحمت زیادی کشیدم...
امیدوارم که برای دوستان گلم و مدیران عزیز قابل قبول باشه.
اینشاءالله اگه باز هم مطلب جدیدی بود واستون می زارم.

[sina_saravi1]

چگونه می توان هندل ( Handle ) یک Textbox را در یک پنجره بدست آورد ؟
پاسخ : برای بدست آوردن هندل پنجره برنامه ای که هم اکنون باز است از تابع FindWindow استفاده کنید . نحوه declare کردن آن بصورت زیر است :
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
فرض کنید caption فرم برنامه مورد نظرتان در متغیر strWindowName قرار داشته باشد . با دستور زیر می توانید هندل پنجره آنرا بدست آورید :
Dim hwndFound As Long
hwndFound = FindWindow(vbNullString, strWindowName)
نکته : برای پیدا کردن هندل پنجره برنامه ای که caption آنرا بطور دقیق نمی دانید می توانید از تابع FindWindowLike استفاده کنید .
حال که هندل پنجره مورد نظرتان را استخراج کردید می توانید با استفاده از تابع FindWindowEx هندل اشیا موجود در آن پنجره را بدست آورید . نحوه declare کردن این تابع بصورت زیر است :
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
این تابع را بصورت زیر استفاده کنید :
htextbox = FindWindowEx(hwndFound, ByVal 0&, "ThunderRT6TextBox", vbNullString)
که ThunderRT6Textbox نام کلاس Rich Textbox ها در ویژوال بیسیک 6 است . دستور فوق هندل اولین Textbox موجود در پنجره را به شما بر می گرداند . برای بدست آوردن هندل سایر Textbox ها از حلقه زیر استفاده کنید :
Dim lChild As Long
Dim lLast As Long

Do
lLast = lChild
lChild = FindWindowEx(lParent, lChild, "ThunderRT6Textbox", vbNullString)
Loop While lChild

سلام
خسته نباشید
واقعا از تلاشتون ممنونم

خوب میتونید از این موضوع یه مثال بزنید؟
مثلا پیدا کردن هندل ورودی چت یاهو:متفکر:

[parsiyan_mohsen]

یه تکست بزار و جای strWindowName بنویس text1.text سپس داخل تکسی بنویس :yahoo m....

[sina_saravi1]

یه تکست بزار و جای strWindowName بنویس text1.text سپس داخل تکسی بنویس :yahoo m....

لطفا کمی بیشتر توضیح بدید!

من تو این مسائل خیلی مبتدی هستم

[sina_saravi1]

چگونه می توان هندل ( Handle ) یک Textbox را در یک پنجره بدست آورد ؟
پاسخ : برای بدست آوردن هندل پنجره برنامه ای که هم اکنون باز است از تابع FindWindow استفاده کنید . نحوه declare کردن آن بصورت زیر است :
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
فرض کنید caption فرم برنامه مورد نظرتان در متغیر strWindowName قرار داشته باشد . با دستور زیر می توانید هندل پنجره آنرا بدست آورید :
Dim hwndFound As Long
hwndFound = FindWindow(vbNullString, strWindowName)
نکته : برای پیدا کردن هندل پنجره برنامه ای که caption آنرا بطور دقیق نمی دانید می توانید از تابع FindWindowLike استفاده کنید .
حال که هندل پنجره مورد نظرتان را استخراج کردید می توانید با استفاده از تابع FindWindowEx هندل اشیا موجود در آن پنجره را بدست آورید . نحوه declare کردن این تابع بصورت زیر است :
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
این تابع را بصورت زیر استفاده کنید :
htextbox = FindWindowEx(hwndFound, ByVal 0&, "ThunderRT6TextBox", vbNullString)
که ThunderRT6Textbox نام کلاس Rich Textbox ها در ویژوال بیسیک 6 است . دستور فوق هندل اولین Textbox موجود در پنجره را به شما بر می گرداند . برای بدست آوردن هندل سایر Textbox ها از حلقه زیر استفاده کنید :
Dim lChild As Long
Dim lLast As Long

Do
lLast = lChild
lChild = FindWindowEx(lParent, lChild, "ThunderRT6Textbox", vbNullString)
Loop While lChild

ممنونم از راهنمایی هاتون

لطفا طریقه ی کار با این تابع رو هم یاد بدید (FindWindowLike)
بسیار ممنونم از زحماتتون

[parsiyan_mohsen]

دوست عزیز من کاملاً در رابطه باهاش توضیح دادم/...:متفکر:

[parsiyan_mohsen]

طراحي :
اين پروژه شامل دو فرم مي باشد كه وظيفه فرم اول دريافت پسورد از كاربر و چك كردن آن با پسورد ذخيره شده در فايل Dll است ، اگر پسوردها يكسان نبودند ، كاربر با پيام I'm Sorry مواجه مي شود و اگر دو پسورد يكسان بودند ، برنامه پس از فرستادن پيام Ok ، فرم دوم را ظاهر مي كند كه در آن كاربر مي تواند پسورد درون فايل Dll را تغيير دهد .
برنامه نويسي فرم اول :
در اين فرم از يك شي Text Box و يك شي Command Button استفاده مي كنيم .
در Command 1 اين قطعه را وارد مي كنيم :

Private Sub Command1_Click()
Open "d:\p.dll" For Input As #1
Input #1, c$
For i = 1 To Len(c$)
a = Mid(c$, i, 1)
r = Asc(a)
r = r - 70
d$ = d$ + Chr(r)
Next
If d$ = Text1.Text Then
MsgBox (" Ok Your Password Is Correct ")
Form2.Show
Form1.Hide
Else
MsgBox (" I'm Sorry , Your Password Is Correct ")
End If
Close
End Sub

در خط يك برنامه فايل Dll براي خواندن باز مي شود .
در خط دوم برنامه تمام محتويات فايل Dll در متغير C$ قرار داده مي شود .
حال با يك حلقه تكرار و استفاده از تابع Mid به تك تك كاراكتر هاي برنامه دسترسي پيدا مي كنيم ، در خطوط بعدي اين كاراكترهاي رشته اي به كد اسكي تبديل شده و از اين كاراكترها 70 عدد كم مي كنيم ( چون در ابتدا 70 تا براي امنيت به كاراكترها اضافه كرده بوديم ) . در آخر حلقه هم ، كدهاي اسكي را به كاراكتر تبديل كرده و در يك متغير رشته اي D$ ذخيره مي كنيم .
شرط ها هم مطابق بودن يا نا مطابق بودن دو پسورد را چك مي كند .كه اگر يكسان بودند ، پيام Ok را ارسال و فرم دوم را ظاهر مي كند .
برنامه نويسي فرم دوم :
ما ، در اين فرم از سه Command button تحت عنوان هاي Change Password ، Sign Out ، Quit و يك Textbox استفاده مي كنيم .
اصل برنامه ما در دكمه تغيير پسورد است يا Change Password است ، قطعه برنامه زير را در قسمت برنامه نويسي اين Command Button استفاده مي كنيم :

Private Sub Command1_Click()
For i = 1 To Len(Text1.Text)
a = Mid(Text1.Text, i, 1)
r = Asc(a)
r = r + 70
c$ = c$ + Chr(r)
Next
Open "d:\p.dll" For Output As #1
Write #1, c$
Close
End Sub

در اين قطعه كد يك پسورد از ورودي دريافت مي شود و همانطور كه قبلا نيز توضيح داده شد ، پس از اعمال تغييراتي براي حفظ امنيت پسورد در يك فايل Dll ذخيره مي شود .

قطعه كد كليد Sign Out :
Private Sub Command2_Click()
Form1.Show
Form2.Hide
End Sub
قطعه كد كليد Quit :
Private Sub Command3_Click()
End
End Sub

[parsiyan_mohsen]

چطور ميشه کنترلي نوشت که اگه چند تا از اونها رو توي فرم بندازيم بتونن همديگرو پيدا کنن مثله Raido
Button

Dim c As Control
For Each c In UserControl.Parent.Controls
If TypeOf c Is UserControl1 Then
MsgBox c.Name
' Put your code here
End If
Next

[parsiyan_mohsen]

ترفــــــــــــــــــــــ ــــــــند :
اگه موقع اجرای برنامه ها در محیط ویژوال بیسیک برنامه در یک حلقه گیر کرد یا هنگ کرد میتونید با زدن کلید های control + Pause break برنامه رو متوقف کنید.

[parsiyan_mohsen]

اموزش ساخت loading... برای شما
اول یک متغیر درست می کنیم

Dim i As Integer

روی فرم کلیک می کنیم

Private Sub Form_Activate
startup.Enabled = True
End Sub
بعد دو کلید ctrl+t با هم فشار می هیم
شما باید این گزینه microsoft windows common controls 6.0 را فعال کنید بعد ok کنید
و یک ProgressBar1 را به فرم اضافه کنید
و بعد یه timer درست می کنیم با نام startup
و بعد در قسمت خصوصیات timer
enbale=false
interval =170
left =6360
top=5160 قرار میدهیم
روی timer در فرم دوبار کلیک می کنیم و این کد را وارد می کنیم

Private Sub STARTRUN_Timer
If i = 99 Then
Unload Me
STARTup.Enabled = False
End If
i = i + 1
ProgressBar1.Value = ProgressBar1.Value + 1
End Sub

[parsiyan_mohsen]

اموزش برنامه نویسی یک 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

[parsiyan_mohsen]

با اين روش مثلا ميتونين برنامه اي كه موس روش هست رو ببندين.واسه اين كار از تابع 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 تا روش براي اين كار گفتم

[parsiyan_mohsen]

حالا بريم سراغ نوشتن تابع كنترل پيغام ها.
توي محيط اسمبلي يا مثلا 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 استفاده ميشن

[parsiyan_mohsen]

برنامه نویسی 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 استفاده ميشن

[parsiyan_mohsen]

الان میخوام کدی رو بگذارم که باهاش میشه اون 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

[parsiyan_mohsen]

برنامه نویسی 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 بزنین

[parsiyan_mohsen]

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

منبع : مایکروسافت

[parsiyan_mohsen]

این تابع hDc ی یه پنجره و اشاره گر یه آیکون رو میگیره و اون رو توی پنجره رسم میکنه:

Private Declare Function DrawIcon Lib "user32" Alias "DrawIcon" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long

آرگومان اول hdc ی پنجره مقصد هستش.دومی X نقطه شروع رسم و بعدی Y اون نقطه هستش.بعدی هم اشاره گر آیکون مورد نظره.
ُخصوصیت AutoRedraw فرم رو True کنین و کد زیر رو وارد کنین:

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub Form_Load()
Dim strpath As String, Buffer As String * 255, Cnt As Long
GetSystemDirectory Buffer, 255
strpath = Replace(Buffer, Chr(0), "") & "\Shell32.dll"
'///
Call DrawIcon(Me.hdc, 0, 0, ExtractIcon(0, ByVal strpath, 20))
End Sub

اول با تابع getsystemdirectory محل پوشه سیستم و بعد محل فایل Shell32.dll رو پیدا میکنیم.بعد هم آیکونی که Index ش 20 هست رو روی فرم رسم میکنیم

[parsiyan_mohsen]

با عرض پوزش اسم تابع بالایی Drawicon است
--------------------------------------------------------------------------------------------------
ExtracIcon

اين تابع يه اشاره گر از آیکونی که توی یه فایل (اغلبا .dll) قرار گرفته بر میگردونه که از با استفاده از این اشاره گر میشه تابع رو روی یه پنجره رسم کرد(و ذخیرش کرد) :

Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

آرگومان اول رو 0 قرار بدین.دومی آدرس فایل مورد نظره.سومی هم Index آیکونی هستش که توی فایل قرار گرفته.(آیکون هایی که به این صورت توی فایل ها قرار میگیرن دارای یه Index هستن)
یکسری از ایکون های ویندوز توی فایل [WinDrive]:\Windows\System\Shell32.dll قرار گرفتن
مثالش رو توی تابع بعد ببینین

[parsiyan_mohsen]

TextOut
این تابع واسه چاپ کردن یه متن روی یه پنجره بکار میره:

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

آرگومان اول hdc ی پنجره مورد نظره.دومی و سومی هم x و y ی مختصات نقطه ای هستش که مخواهیم متن چاپ بشه و اینجا نقطه 0 و 0 بالا سمت چپ پنجره مورد نظره بعدي هم متن مورد نظره بعدی .تعدد کاراکتری هستش که میخواهیم از متنی که به تابع دادیم از سمت چپ جدا بشه و چاب بشه که معمولا چون میخواهیم همه متن چاپ بشه باید این مقدار برار طول متن باشه.در ضمن متن با فونت و رنگ زمینه پنجره ای که hdc ش رو به تابع دادیم رسم میشه:

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Sub Command1_Click()
Dim strText As String, Cnt As Long
strText = "API : Application programming interface... |"
For Cnt = 0 To 2
TextOut GetDC(0), 20 * Cnt * 20, Screen.Height / 30, ByVal strText, Len(strText)
Next
End Sub

[parsiyan_mohsen]

این تابع هم کار تابع قبلی رو میکنه با این فرق که متن داخل یه محدوده چهار گوش شکل رسم میشه و میشه مشخص کرد با چه فرمتی(حالتی) این کار انجام بشه:

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

آرگومان های اول و دوم و سوم رو قبلا توضیح دادم.چهارمی هم یه متغیر از نوع rect که محدوده چهار گوش رو مشخص میکنه.پنجمی هم نوع چاپ شده هستش که مقدار هایی مثل این هارو میشه به تابع داد :

Private Const DT_BOTTOM = &H8 متن در پایین محدوده rect چاپ میشه
Private Const DT_CENTER = &H1 متن در وسط محدوده rect چاپ میشه
Private Const DT_LEFT = &H0 متن در سمت چپ محدوده rect چاپ میشه
Private Const DT_RIGHT = &H2 متن سمت راست محدوده rect چاپ میشه

به کد زیر توجه کنین:

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_CENTER = &H1
Private Sub Command1_Click()
Dim strText As String, R As RECT
R.Bottom = 200
R.Top = 0
R.Left = 0
R.Right = Screen.Width / 15
strText = "Applicatrion Programming Interface"
DrawText GetDC(0), ByVal strText, Len(strText), R, &H1
End Sub

توی این کد توی محدوده rect نقطه بالا و چپ 0 و 0 قرار داده شده (گوشه سمت چپ پنجره) و قسمت پایین rect 200 و سمت راست اون به اندازه عرض صفحه نمایش قرار داده شده
و فرمت هم Center (مرکز) قرار داده شده بنابراین وقتی تابع رو فرخوانی میکنیم y ی چیزی که چاپ شده 0 هستش و چون ما فرمت رو مرکز قرار دادیم x متنی که چاپ شده به اندازه نصف عرض صفحه نمایش هستش و وسطش چاپ میشه.

[parsiyan_mohsen]

یه برنامه مینویسیم که عکس رو از صفحه نمایش بگیره ول اندازه اونو 2 برابر کنه و اونو ذخیره کنه.یه دکمه و یه PictureBox بزارین و خصوصيت autoredraw ش رو true كنين :

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Sub Command1_Click()
Picture1.AutoRedraw = True
Picture1.Width = Screen.Width * 2
Picture1.Height = Screen.Height * 2
Me.Hide
StretchBlt Picture1.hdc, 0, 0, Screen.Width / 7.5, Screen.Height / 7.5, GetDC(0), 0, 0, Screen.Width / 15, Screen.Height / 15, SRCCOPY
Me.Show
SavePicture Picture1.Image, "D:\test.bmp"
End Sub

[parsiyan_mohsen]

GetCurrentDirectory

این تابع آدرس پوشه ای که برنامه جاری توش داره اجرا میشه رو برمیگردونه.یعنی کار App.path رو انجام میده:

Private Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectory" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

روش مقدار دادن آرگومان هاش هم شبیه تابع قبلیه فقط جای اونا عوض شده یعنی آرگومان اول برای تعداد کاراکتر
اول و آرگومان دوم یه متغییر واسه قرار دادن آدرس توی اون:

Private Declare Function GetCurrentDirectoryA Lib "kernel32" Alias "GetCurrentDirectory" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Sub Form_Load()
Dim buffer As String * 255
GetCurrentDirectoryA 255,Buffer
MsgBox "Current Directory : '" & Replace(buffer, Chr(0), "") & "'"
End Sub

[parsiyan_mohsen]

GetComputerName

این تابع نام کامپیوتری که برنامه داره توش اجرا میشه رو برمیگردونه.این اسم رو میتونین توی قسمت
System Properties (راست کلیک روی My Computer ؛ رفتن به Properties ) توی قسمت Computer Name ببینین.

Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

آرگومان اول یه متغیر هست که تابع نام مورد نظر رو توی این قرار میده و طولش باید از قبل تعیین شده باشه.آرگومان دوم هم مشخص میکنه که چند کاراکتر اول نام کامپیوتر توی متغیر قرار بگیره.این عدد باید با طور متغیر برابر باشه یا کوچکتر.بهتره جفتشون رو 255 قرار بدین.:

Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub Form_Load()
Dim buffer As String * 255
GetComputerName buffer, 255
MsgBox "Computer name : '" & Replace(buffer, Chr(0), "") & "'"
End Sub

[parsiyan_mohsen]

GetForeGroundWindow
این تابع هندل فرم فعال(که رنگ نوار عنوانش با بقیه فرق داره و معمولا آبیه) رو برمیگردونه:

Private Declare Function GetForegroundWindow Lib "user32" () As Long

هیچ مقداری هم نیاز نیست بش بدیم.یه تایمر توی فرم بزارین و Interval ش رو 1 بزارین:

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Sub Timer1_Timer()
Me.Caption = GetForegroundWindow()
End Sub

[parsiyan_mohsen]

FlashWindow

این تابع واسه آبی کردن و بعد به رنگ معمولی در آوردن (میشه گفت نور انداختن) عنوان و اسم یه (پنجره)فرم توی TaskBar بکار میره .شاید منظورمو نفهمیده باشین.ازش استفاده کنین تا بفهمین:

Private Declare Function FlashWindow Lib "user32" Alias "FlashWindow" (ByVal hwnd As Long, ByVal bInvert As Long) As Long

آرگومان اول هندل پنجره مورد نظر هست.
آرگومان دوم رو 1 قرار بدین (اگه صفر قرار بدین عمل مورد نظر–اگر در حال انجام باشه- متوقف میشه)
یه دکمه توی فرم بزارین:

Private Declare Function FlashWindow Lib "user32" Alias "FlashWindow" (ByVal hwnd As Long, ByVal bInvert As Long) As Long

Private sub Command1_Click()
FlashWindow Me.hWnd , 1
End Sub

[parsiyan_mohsen]

.BlockInput
این تابع بعد از فراخوانیش موس و کیبرد رو قفل میکنه یعنی دیگه کلید هایی که میزنین بر پنجره ها اثر نداره و موس رو که تکون میدین کرسرش حرکت نمیکنه:

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long

مقداری که میگیره اگه 0 باشه عمل قفل شدن متوقف میشه و اگه 1 باشه موس و کیبرد قفل میشه.اگه با این تابع موس و کیبرد رو قفل کردین یه فکری هم به فکر آزاد کردن موس و کیبرد باشین :
یه تایمر توی فرم بزارین :

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long

Private Sub Form_Load()
Timer1.Interval = 5000
BlockInput True
End Sub
Private Sub Timer1_Timer()
BlockInput False
End Sub

با این کد عمل قفل شدن 5 ثانیه طول میکشه.

[parsiyan_mohsen]

Sleep
این تابع برنامه ای که تابع توش فراخوانی شده رو توی زمانی که بش میدیم متوقف میکنه
آرگومانی که میگیره زمان مورد نظره که بر حسب میلی ثانیه هستش.
یه دکمه توی فرم بزارین :

Private Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

Private Sub Command1_Click()
Sleep 2000 '2000 ms = 2 s
End Sub

[parsiyan_mohsen]

.CreateDirectory
این تابع واسه ساختن Folder بکار میره :

Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

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

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

برای مثال :

Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Dim SA as SECURITY_ATTRIBUTES
Private Sub Form_Load()
Createdirectory "D:\APItest",SA
End Sub

[parsiyan_mohsen]

.SetWindowPos
این تابع واسه تغییر مکان و تغییر اندازه Window ها بکار میره و چند تا کاره دیگه هم میکنه:

Private Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

مقدار اولی که میگیره هندل پنجره هستش.دومی طرز قرار گیفتن پنجره در محور z هستش.مثلا بالاتر از پنجره های دیگه قرار بگیره یا پایین تر و ... .مقدار هایی که این میگیره:

Private Const HWND_BOTTOM = 1
Private Const HWND_BROADCAST = &HFFFF&
Private Const HWND_DESKTOP = 0
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1

هر کدوم از اینارو بزارین ببینین چی میشه . مثلا topmost بالای پنجره های دیگه جتی اونایی که از قبل
Top بودن قرار میگیره.

مقدار سومی و چهارم هم x و y مختصات پنجره هستش که نسبت به پنجره parent (مادر) ش هستش به طوری که بالا و سمت چپ پنجره ء مادر نقطه (0 ، 0 ) حساب میشه.مقدار بعدی هم عرض و طول پنجره مورد نظر هستش.
حالا اگه نخواهیم همه این خصوصیات پنجره رو تغییر بدیم نمیشه مثل ویبی اونا رو مقدار دهی نکنیم.بعضی از مواقع میشه از Byval 0& استفاده کرد اما در مورد این تابع واسه اینکه نخواهیم همه خصوصیاتش رو تغییر بدیم باید آرگومان آخر رو مقدار دهی کنیم.بعضی از مقدار هایی که این میگیره :

Private Const SWP_NOMOVE = &H2 پنچره تغییر مکان نمیده
Private Const SWP_NOACTIVATE = &H10 پنجره فعال نمیشه
Private Const SWP_NOSIZE = &H1 پنجره تغییر اندازه نمیده
Private Const SWP_NOZORDER = &H4 جای پنجره در محور z عوض نمیشه
Private Const SWP_NOREDRAW = &H8 پنجره دوباره رسم نمیشه

یه تایمر و یه دکمه توی فرم بزارین و کد زیر رو وارد کنین:

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Dim x As Integer, y As Integer

Private Sub Form_Paint()
Command1.SetFocus
Timer1.Interval = 100
End Sub

Private Sub timer1_timer()
x = Int(800 * Rnd())
y = Int(600 * Rnd())
SetWindowPos Me.hwnd, 0, x, y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER
End Sub
Private Sub command1_click()
Unload Me
End Sub

اول focus رو به دکمه میدیم بعد .Interval مربوط به تایمر رو مقدار دهی میکنیم.توی Private Sub timer1_timer هم یه x و y
به طور تصادفی بدست میاریم توی خط بعد هم با استفاده از تابع مورد نظر پنجره رو حرکت میدیم.
حالا بعد از اجرا کردن برنامه کلید اینتر رو که بزنین برنامه بسته میشه.

[parsiyan_mohsen]

SetSystemCursor
با این تابع میشه کرسر سیستم رو تعیین کرد.این تابع اول یه اشاره گر از کرسر مورد نظر ما میخواد که ما این رو با استفاده از تابع LoadCursorFromFile میگیریم آرگوما دوم رو هم Private Const OCR_NORMAL = 32512 قرار بدین(مقدار های دیگه رو میتونین توی API Viewer ببینین).یه دکمه توی فرم بزارین:

Private Declare Function SetSystemCursor Lib "user32" Alias "SetSystemCursor" (ByVal hcur As Long, ByVal id As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Const OCR_NORMAL = 32512

Private Sub Command1_Click()
Dim hc as long
hc = LoadCursorFromFile("D:\c.cur")
SetSystemCursor hc,32512
End Sub

فایلهای با پسوند .cur که با ویژوال بیسیک نصب شدن رو توی شاخه …\COMMON\GRAPHICS\CURSORS پیدا کنین.به امید دیدار.

[parsiyan_mohsen]

LoadCursorFromFile
این تابع اشاره گر یه فایل کرسر (.cur) رو به مامیده که ازش میشه توی تابع SetSystemCursor استفاده کرد.مثالش رو توی تابع بعدی ببینین.

Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long

[parsiyan_mohsen]

GetAsyncKeyState
با این تابع میتونین بفهمین که قبل از فراخوانی تابع آیا یه کلید فشرده شده یه نه.آرگومانی که تابع میگیره کلیدی که مورد نظرمون هست رو مشخص میکنه.برای مثال

Private Const VK_LEFT = &H25

مربوط به کلید چپ هست.کلیه مقدار ها رو میتونین توی API Viewer پیدا کینین.مقدار برگشتی تابع مشخص میکنه که کلید مور د نظر فشرده شده یا نه .یه دکمه توی فرم بزارین:

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const VK_LEFT = &H25

Private Sub Command1_Click()
If GetAsyncKeyState(VK_LEFT) Then
Print "<--"
End if
End Sub

در ضمن اگه شما مقدار &H8000 رو هم توی شرط If بزارین عمل چاپ فقط در صورتی که اجرا میشه که کلید چپ در زمان فشره شدن دکمه فشرده شده باشه نه قبلش.
البته در حالت اول برای یک بار فشردن دکمه چپ فقط یک بار عمل چاپ با فشردن دکمه انجام میشه.امتحان کنین تا منظورمو بفهمین

[parsiyan_mohsen]

GetClassName
این تابع هندل یه پنجره رو میگیره و ClassName ش رو برمیردونه.آرگومان اول هندل پنجره.آرگومان دوم یه متغیر که نام کلاس توش قرار میگیره طول این متغییر باید تعیین شده باشه.سومی هم یه عدد مثل n که وقتی به تابع داده میشه تابع n-1 کاراکتر اول نام کلاس رو داخل متغییر قرار میده.(البته مطمین نستم شایدم n کاراکتر اول رو برگردونه.خودم امتحان کردم n-1 کاراکتر اول رو قرار داد)این عدد رو 255 قرار بدین خیال خودتونو راحت کنین.

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Sub Command1_Click()
Dim ipCName as String * 255
GetClassname Me.hWnd,ipCName,255
Msgbox Replace(ipCName,chr(0),"")
End Sub

[parsiyan_mohsen]

تابع PlaySound
این تابع واسه پخش کردن یه فایل با فرمت wav از توی speaker هاست.آرگومان اول آدرس فایل و دومی و سومی باید 1 باشه.یه دکمه توی فرم بزارین و کد زیر رو وارد کنین:

Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private Sub Command1_Click()
PlaySound "D:\File.wav",1,1
End Sub

که باید به جای D:\File.wav آدرس یه فایل با پسوند wav بزارین.

[parsiyan_mohsen]

SetForegroundWindow اين تابع هندل يم پنجره رو ميگيره و اونو فعال ميكنه:

Private Declare Function SetForegroundWindow Lib "user32" Alias "SetForegroundWindow" (ByVal hwnd As Long) As Long

با استفاده از تابع GetCursorPos مكان موس رو ميگيريم و با استفاده از از تابع WindowFromPoint بوسيله مختصات هندل رو ميگيريم و به تابع ميديم(يه تايمر توي فرم بزارين):

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" Alias "SetForegroundWindow" (ByVal hwnd As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Dim PAPI As POINTAPI,phWnd as long

Private Sub Form_Load()
Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
GetCursorPos PAPI
phWnd = WindowFromPoint(PAPI.x, PAPI.y)
SetForeGroundWindow phWnd
End Sub

[parsiyan_mohsen]

GetSystemDirectory
اين تابع براي گرفتن آدرس پوشه سيستم بكار ميره مثلا در ويندوز 98 اگه ويندوز در درايو C نصب شده باشه محل اغلبا"
C:\Windows\System هست.
اين تابع به اين صورته:

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

مقدار اول يه متغير از نوع String هست كه بايد به تابع بديم تا مسير رو توي اون قرار بده.و دومي رو 255 قرار بدين.اين مقدار
نشون ميده كه تابع حداكثر چند كاراكتر اول مسير رو برگردونه.چون طول اين مسير به ندرت 255 ميشه ما اين عدد رو بش ميديم.يه نكته رو توجه كنين كه اين تابع مقدار 255 كاراكتر(كه خودمون مشخص كرديم) رو داخل متغييري كه بش داديم قرار ميده كه كاراكتر هاي اول رو مسير پوشه سيستم و بقيه رو با كاراكتر 0 پر ميكنه.بنابراين ما بايد طور متغير كه در عادي 0 هست رو به 255 تغيير بديم و گرنه چون تابع ميخواد مقدار رو درون تابع جا بده و تابع جا نداره(طولش 0 هستش) اشكال ايجاد ميشه و برنامه ما بسته ميشه.همن اين ها به اين علت هستش كه تابع طول متغير ما رو تغيير نميده(ولي در خود ويبي اگر يه مقداري رو به يه متغير از نوع String بديم طول متغيير خودكار اضافه ميشه.)
براي اينكه ما طول متغير رو براي اين تابع به مقدار 255 كاراكتر تغيير بديم 2 كار ميتونيم بكنيم.يكي از اين روشه:
Dim sysPath as string * 255
توي اين روش طول متغير با استفاده از 255 كاراكتر تغيير ميكنه.(با استفاده از كاراكتر 0‌)
يا اينكه يه مقدار با طول 255 به متغيير ميديم:

Dim sysPath as String
sysPath = String(255," ")

حالا تابع رو فراخواني ميكنيم:

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub Form_Load()
Dim sysPath as String * 255
GetSystemDirectory sysPath,255
Msgbox Replace(sysPath,chr(0),"")
End Sub

در خط يكي مونده به آخر با استفاده از تابع Replace مقدار كاراكتر 0 اضافي كه با تابع داده شده حذف ميشه.

[parsiyan_mohsen]

GetWindowsDirectory
اين تابع مسير پوشه ويندوز رو برميگردونه و روش كار باش مشابه قبلي هست :

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub Form_Load()
Dim winPath as String * 255
GetWindowsDirectory winPath,255
Msgbox Replace(winPath,chr(0),"")
End Sub

[parsiyan_mohsen]

GetTempPath
اين تابع هم مسير پوشه Temp رو به ما ميده و يه فرق كوچيك با قبليه داره . جاي آرگومان هاش عوض شده:

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nSize As Long,ByVal pBuffer As String) As Long
Private Sub Form_Load()
Dim tmpPath as String * 255
GetTempPath 255,tmpPath
Msgbox Replace(tmpPath,chr(0),"")
End Sub

[parsiyan_mohsen]

GetBkColor : اين تابع BackColor يا رنگ زمينه پنجره اي كه hDC ش رو بش داديم برميگردونه:

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

براي مثال Hdc فرم خودمون رو بش ميديم و مقدار بازگشتيشو با BACKcOLOR فرممون مقايسه ميكنيم(1 دكمه توي فرم بزارين):

Private Declare Function GetBkColor Lib "gdi32" Alias "GetBkColor" (ByVal hdc As Long) As Long
Private Sub Form_Load()
Me.BackColor=VbBlue
End sub
Private Sub Command1_Click()
Dim BKcolor as Long
BKcolor = GetBkColor(Me.hdc)
If BKcolor = Me.BackColor Then
Msgbox "Good!",vbinformation
Else
Msgbox "Wrong!!",vbCritical
End If
End Sub

توجه كنين كه من در Private Sub Form_Load() رنگ زمينه فرم رو از حالت پيشفرض خارج كردم و يه رنگ معمولي بش دادم اين به اين دليل بود كه فرم در حالت پيشفرض داراي رنگ زمينه VbFaceButton (يه رنگ سيستمي) هست و براي همين هم خصوصيت Me.BackColor بجاي اينكه رنگ زمينه واقعي رو برگردونه يه چيز ديگه برميگردونه.

[parsiyan_mohsen]

AnimateWindow
اين تابع رو بايد در حالتي كه يه پنجره هنوز رسم نشده(يا Hide هست و ...) و يا قبل از پنهان شدن هست بايد فراخواني كرد
بعد از فراخواني تابع پنجره در حالتهاي مختلف به صورت انيميت رسم ميشه يا پنهان ميشه.مثلا از سمت چپ طولش افزايش پيدا ميكنه تا كاملا رسم بشه.اين تابع توي API Viewer نيست:

Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean

ثابت هاي مورد نياز:

Const AW_HOR_POSITIVE = &H1
Const AW_HOR_NEGATIVE = &H2
Const AW_VER_POSITIVE = &H4
Const AW_VER_NEGATIVE = &H8
Const AW_CENTER = &H10
Const AW_HIDE = &H10000
Const AW_ACTIVATE = &H20000
Const AW_SLIDE = &H40000
Const AW_BLEND = &H80000

اين تابع 3 تا مقدار به صورت byVal ميگيره.اول هندل پنجره مورد نظر.دومي زماني كه ميخواهيم عمل رسم انجام بشه سومي هم روش رسم هست كه بايد ثابت ها را به اين بديم.بعضي از مقادير (آخر) رو ميشه از طريق Or با هم استفاده كرد.
موقتي كه ميخواهيم يك پنجره از حالت رسم شده به حالت پنهان بره بايد مقدار AW_HIDE رو هم به پارامتر آخر (با استفاده از Or) اضافه كنيد.كارهايي كه اين ثابت ها ميكنن:

AW_HOR_POSITIVE پنجره از چپ به راست رسم يا پاك ميشه
AW_HOR_POSITIVE پنجره از راست به چپ رسم يا پاك ميشه
AW_VER_POSITIVE پنجره از بالا به پايين رسم يا پاك ميشه
AW_VER_NEGATIVE پنجره از پايين به بالا رسم يا پاك ميشه
AW_CENTER پنجره از مركز باز ميشه يا بالعكس
AW_ACTIVATE پنجره رو فعال ميكنه

بقيه رو هم درست نفهميدم شما هم امتحان كنين.
يه مثال ميزنم.2 تا دكمه داخل فرم درست كنين و كد زير رو وارد كنين:

Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean
Const AW_HOR_POSITIVE = &H1
Const AW_HOR_NEGATIVE = &H2
Const AW_VER_POSITIVE = &H4
Const AW_VER_NEGATIVE = &H8
Const AW_CENTER = &H10
Const AW_HIDE = &H10000
Const AW_ACTIVATE = &H20000
Const AW_SLIDE = &H40000
Const AW_BLEND = &H80000
Private Sub Form_Load()
Me.BackColor = vbBlue
AnimateWindow Me.hwnd, 1000, AW_HOR_POSITIVE Or AW_VER_NEGATIVE
Me.Cls
End Sub
Private Sub Command1_Click()
If Command2.Visible = True Then
AnimateWindow Command2.hwnd, 1000, AW_CENTER Or AW_HIDE: Command2.Visible = False
Else
AnimateWindow Command2.hwnd, 1000, AW_CENTER: Command2.Visible = True
End If
End Sub

براي اينكه بعد از رسم تغيير رنگ هاي(احتمالي) ايجاد شده از بين بره(صفحه پاك بشه) از Me.Cls استفاده كردم.
اين رو هم بگم كه در زماني كه تابع داره كارشو ميكنه برنامه كار ديگه اي نميتونه بكنه.در ضمن رنگ زمينه رو عوض كردم تا تغيير اندازه دكمه مشخص بشه.ديگه فكر نكنم توضيحي بخواد.

[parsiyan_mohsen]

اموزش روش های Shut Down

براي Shut Down كردن سيستم از تابعExitWindowEx استفاده ميشه :

Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

پارامتر اول يكي از مقدار هاي زير ميتونه باشه :

Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4

همش به غير از آخري واضحه.آخري با هر كدوم از بقيه كه تركيب بشه (با Or ) موجب ميشه كه ويندوز برنامه ها رو مجبور به بستن كنه.پارامتر دوم رو هم VbNullString قرار بدين
.مثال :

Private Sub Command1_Click()
ExitWindowsEx EWX_SHUTDOWN or EWX_FORCE, VbNULLString
End Sub

توي ويندوز XP اين روش كار نميكنه.براي شات دانون كردن ويندوز بايد از فايل ShutDown.Exe كه توي دايركتوري سيستم هست استفاده كرد.اين فايل واسه Shut Down كردن چند تا پارامتر ميتونه بگيره كه يكيش رو حتما بايد بش بدين :

-I

يه واسط كاربري نشون ميده كه توي اون كاربر Options ها رو مشخص ميكنه و بعد OK ميكنه تا سيستم خاموش بشه و اگه اين رو استفاده كردين ديگه نياز به پارامتر ديكه اي نيست .البته اين پارامتر اصلا به كار ما نمياد.ما ميخواهيم به طور اتوماتيك سيستم رو Shut Down كنيم.

-l

سيستم Logoff ميشه

-s

سيستم Shutdown ميشه.(توي قسمت هاي قبلي هرجا گفتم Shut Down منظورم Restart , Shutdown , Logoff بود)

-r

سيستم Restart ميشه.

-a

اگه سيستم در حال Shut Down شدن باشه ،اين كار لغو (abort)ميشه.

-t [Seconds]

اين براي زمان بكار ميره.يعني اينكه اگه از اين پارامتر استفاده كنين بايد بعدش يه عدد كه معرف ثانيه هستش بنويسين كه اگه اين كارو بكنين يه پنجره مثل اين نشون داده ميشه و سيستم بعد از زماني كه شما تعيين كردين Shut Down ميشه:

-c "[This is a comment] "

اگه از پارامتر t استفاده كرده باشين با اين پارامتر (c) ميتونين توي قسمت Message يه پيغام براي كاربر نشون بدين مثل ايني كه من گذاشتم (This is a comment) در ضمن طول اين پيغام حداكثر بايد 127 كاراكتر باشه.


-f

مثل مقدار EWX_FORCE توي تابع ExitWindowsEx عمل ميكنه يعني اگه ازش استفاده كنين ويندوز برنامه ها رو مجبور به بستن ميكنه.
حالا ما براي Shut Down كردن بايد اين فايل رو با پارامتر ها باز كنيم.از تابع Shell استفاده ميكنيم :
2 تا دكمه يكي cmdShutDown و يكي ديگه cmdAbort درست كنين :

Private Sub cmdShutDown_Click()
Shell "Shutdown.exe -r –t 30 –f –c " & """" & "This is a comment" & """"
End Sub
Private Sub cmdAbort_Click()
Shell "Shutdown.exe –a"
End Sub

وقتي دكمه cmdShutDown رو بزنين يه پنجره مثل پنجره اي كه عكسش رو گذاشتم ظاهر ميشه و شمارش معكوس از 30 شروع ميشه.اگه به 30 برسه ويندوز رستارت ميشه.اگه دكمه cmdAbort رو بزنين پنجره ي Shut Down بسته ميشه.
حالا يه كد واسه رستارت در همون لحظه :

Private Sub cmdShutDown_Click()
If MsgBox("Are you sure? ",VbCritical + VbYesNo) = VbYes Then
Shell "ShutDown.exe –r –f –t 0"
End If
End Sub

[parsiyan_mohsen]

SendKeys يك يا چند كاركتر يا دكمه هاي كيبرد رو به پنجره ي فعال ارسال ميكنه درست مثل اينكه دكمه هاي كيبرد فشار داده شده باشن.2 تا آرگومان ميگيره كه دومي اختياريه.آرگومان اولي كاراكتر هايي هستن كه ميخواهيم ارسال كنيم مثلا “vb” .واسه دكمه هاي خاص كيبرد مثل HOME ها DELETE و ... بايد اون ها رو توي آكلاد قرار بدين مثلا :
براي insert از “{INSERT}” يا “{INS}” استفاده ميشه.
براي end از “{END}” استفاده ميشه.
براي delete از “{DELETE}” يا “{DEL}” استفاده ميشه.
براي page down از “{PGDN}” استفاده ميشه.
براي page up از “{PGUP}” استفاده ميشه.
براي home از “{HOME}” استفاده ميشه.
براي علامت چپ از “{LEFT}” استفاده ميشه.
براي علامت بالا از “{UP}” استفاده ميشه.
براي علامت راست از “{RIGHT}” استفاده ميشه.
براي علامت پايين از “{DOWN}” استفاده ميشه.
براي print screen از “{PRTSC}” استفاده ميشه.
براي scroll lock از “{SCROLLLOCK}” استفاده ميشه.
براي break از “{BREAK}” استفاده ميشه.
براي back space از “{BACKSPACE}” يا“{BS}” يا “{BKSP}” استفاده ميشه.
براي enter از “{ENTER}” يا "~" (بدون آكلاد) استفاده ميشه.
براي F1 ، F2 و... هم از “{F1}” ، “{F2}” و ... استفاده ميشه.
براي escape از “{ESC}” استفاده ميشه.
براي tab از “{TAB}” استفاده ميشه.
براي caps lock از “CAPSLOCK” استفاده ميشه.

واسه نگه داشتنه شدن كليد هاي Control و Alt و Shift به ترتيب از ^ ، % ، + استفاده كنين.مثلا براي كنترل بعلاوه ي v از “^v” استفاده كنين.اگه ميخواهين يكي ازين دكمه ها واسه مجموعه اي از كليد ها مورد استفاده قرار بگيره از پرانتز استفاده كنين مثلا براي كنترل بعلاوه ي vb از “^(vb)” استفاده كنين.براي استفاده همزمان از چند تا ازين كليد ها هم اون ها رو پشت سر هم استفاده كنين مثلا براي شيفت بعلاوه ي كنترل بعلاوه v از “+^v” استفاده كنين.اين كار رو براي دكمه هاي HOME و INSERT و ... هم ميتونين بكنين.مثلا كنترل بعلاوه يHOME ميشه “^{HOME}” .

آرگومان دوم از نوع Boolean هستش كه بطور پيشفرض False هستش.اگه True باشه وقتي كه كليدي به يك پنجره ارسال ميشه تابع منتظر ميشه تا اون پنجره عمليات فشرده شدن كليد رو براي خودش پردازش كنه بعد كنترل به تابع برميگرده.

[parsiyan_mohsen]

FormatDateTime اين تابع واسه تغيير فرمت زمان و تاريخ به كار ميره.آرگومان اول تاريخ يا زمان مورد نظره .دومي هم فرمت مورد نظر.مقدار بازگشتي با توجه به نوع فرمت و نوع مقداري كه بش داديم فرق ميكنه :

FormatDateTime(Now(), vbGeneralDate) = 10/5/2005 10:49:07 PM

[parsiyan_mohsen]

برخي اپراتور هاي Visual Basic

Type Of اپراتور

اين اپراتور براي تشخيص نوع كنترل به كار مي رود.روش استفاده از ان به شكل زير است

TypeOf ControlName Is ControlType

مثال:كنترلي از نوع فايل بوكس رابه تايع زير مي فرستيم يراي تعيين عضو انتخاب شده

Private Function GetSelectItem(LST as Contol) as String
if TypeOf lst is listbox then
GetselectItem=Lst.text:Exit Function
else :GetselectItem=Lst.FileName:Exit Sub
End if

در خط يك تابع با آرگومان يك ليست از نوع كنترل تعريف مي شود خروجي تايپ آف به صورت يك منو مانند تعريف متغيير هنگام كد نويسي ظاهر مي شود كه شما مي توانيد نو ع كنترل خود را از داخل آن انتخاب كنيد.توجه كنيد بين تايپ و آف نبايد فاصله بيفتد واگر نه با خطاي كامپايل مواجه مي شويد.

DoEvents اپراتور

اين اپراتور براي ارجاع تمام عملييات به سي پي يو براي انجام مي باشد.اكثرآ از اين اپراتور براي مواقعي استفاده مي گردد كه يك عمليات وقتگير در حال انجام است مانند اعمال افكت روي تصوير و حلقه هاي تكرار طولاني. اين اپراتور در درون حلقه قرار گرفته و كامپايل نمي شود مانند رهنمود ها در پاسكال عمل مي كندوبه سي پي يو مي گويد تمام كارهيت را به صورت يكسان انجام بده واز اولويت ها صرف نظر كن .در برنامه هايي كه يك عمليات در درون يك حلقه هر دور انجام مي شود آكثرآ باعث هنك كردن آن برنامه تا پايان عمليات مي شود.چون برنامه بين واكنش به تكان خوردن موس -جابه جاكردن برنامه يا بزرگ و كوچك كردن برنامه وپردازش روي عمليات مورد نظر(مثلآ كپي فايل)عمليياتي كه داراي اولويت پردازش است را انتخاب مي كند.اين اپراتور در چنين مواقعي بسيار مفيد است وباعث مي شود كاربر گمان نكند كه برنامه هنك كرده و آن را ببندد.مثال:ِ

For i=0 to list1.listCount -1
if list1.list(i)<>"" then call Copy(list1.list(i),App.path+"\")
DoEvents
Next

در خط اول حلقه اي از صفر تا تعداد اعناصر موجود در ليست اغازمي شودو در هر درو فايل درون ليست در صورت وجود كپي مي شود .اگر فايل هاي مازياد باشد DoEventsو اپراتور را ننويسيم حتمآ برنامه ما هنك مي كند.بايد ياد آور شد استفاده نابجا و بيش از اندازه اين اپراتور موجب كاهش سرعت برنامه مي شود.ِالبته

استفاده مي كنندSleepبه نام APIباعث كاركرد زياد وشديد سي پي يو مي شود وبرخي ترجيح مي دهند از آن استفاده نكنند ويه جاي ان از يك

فرق مي كند. اسليپ باعث ميشود سي پي يو تمام كار هاي در حال اجرا را رها كند وبه مدت زماني كه جلويDoEventsبايد گفت كاركرد اسليپ به طور كلي با

آن نوشته مي شود به استراحت بپردازد.ِ

sleep با توجه به زماني كه براش تعيين ميكني در وسط كار برنامه مكث ايجاد ميكنه و در آن زمان هيچ خطي از كد برنامه اجرا نميشه و همان طور كه از اسم تابع .مشخصه برنامه در آن زمان به خواب ميره
اسليپ زماني كه با محيط خارج از برنامه در ارتباطي خيلي مفيده. چون معمولا وقتي دستوري در وي بي مثل اجراي فلان فايل مدتي طول مي كشد و تو اين مدت دستورات بعدي سريع اجرا مي شوند كه ممكن است نتيجه اش به اجاي فايل بستگي داشته با شه.اسليپ باعث ميشه به ويندوز فرصت بدي ساير دستورات فرستاده شده به خارج برنامه رو اجرا كنه. البته گاهي اوقات هم نميدونيم چند ثانيه مكث كنيم و ممكنه مجبور شيم براي احتياط زمان زيادي مكث كنيم كه سرعت برنامه مياد پايين پس تا مي تونيم از دستورات خود وي بي استفاده كنيم تا بر نامه هاي خارجي.ِ

[parsiyan_mohsen]

فرمت فایل M3U
چگونه یک فایل PlayList با پسوند M3U بسازیم

گاهي وقتي عده ي زيادي فايل را در مدیا پلير يا وينمپ باز مي كنيم يك گزينه به نام SavePlaylist
مي بينيم كه براي ذخيره كردن آن ليست در يك فايل استفاده مي شود.اگر يك برنامه ي پخش صوت يا تصوير باكنترل مديا پلير نيز بنويسيد براي پخش هم زمان چندين فايل به مشكل برخواهيد خورد .درچنين مواقعي مي توانيم با ذخيره ليست در يك فايل ام تري يو وباز كردن آن در كنترل مديا پلير چندين فايل را با هم پخش كرد .شايد شما بتوانيد فايل هايتان را مستقيمآ به ليست مديا پلير احتياج به دانستن فرمت فايل ام تري يو داريدPlayListاضافه كنيد ولي باز هم براي ذخيره

با اين تابع اين كار را انجام دهيد

Public Sub SaveList(OutPath As String,Lst as ListBox)
On Error Resume Next '--------------------------------------------------
Dim T3 As String, T2, strans As String, L As Single, i As Integer
T3 = "": T2 = ""
If Lst.List(1) = "" Then
strans = MsgBox("File Not Found!", vbCritical)
Exit Sub '------------------------------------------------------
End If
If UCase(Right(OutPath, 3)) <> "M3U" Then Exit Sub
Open OutPath For Output As #1
Print #1, "#EXTM3U:"
For i = 1 To Lst.ListCount '----------------------------
Print #1, "#EXTNIF:"
Print #1, Lst.List(i)
Next i '------------------------------------------------------
Close #1
End Sub

حال براي زخيره كردن فايل هاي صوتي و تصويري موجود در يك ليست تنها به دستور زير نياز داريد

SaveList "C:\1.M3U",List1

[parsiyan_mohsen]

كتابخانه وسيع Shell

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal_ lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal_ nShowCmd As Long) As Long

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

Shell "arp"
Shell "drvspace"
Shell "drwatson"
Shell "explorer"براي my document
Shell "freecell"
Shell "ftp"براي تنظيم اف تي پي
Shell "ipconfig"كادر آي پي
Shell "mplayer"مديا پلير
Shell "mshearts"
Shell "nbtstat"
Shell "netstat"
Shell "calc"ماشين حساب
Shell "notepad"نوت پد
Shell "packager"
Shell "pbrush"نقاشي
Shell "ping"
Shell "regedit"ريجيستري
Shell "route"روت
Shell "scandskw"اسكن ديسك
Shell "scanregw"اسكن رگ
Shell "setdebug"كخك تري تنظيم ويندوز
Shell "sigverif"
Shell "cdplayer"سي دي پلير
Shell "sndrec32"ضبط صدا
Shell "sndvol32"تنظيم ولوم صدا
Shell "sol"همون سول
Shell "taskman"وضعيت سي پي يو
Shell "telnet"تلفن
Shell "vcmui"
Shell "winfile"
Shell "winipcfg"
Shell "winmine"
Shell "winrep"
Shell "charmap"كاراكتر مپ
Shell "winver"
Shell "write"وورد پد
Shell "wscript"
Shell "cleanmgr"كلنر پاك كننده اشغال درايو
Shell "control"كنترل پنل
Shell "cvt1"
Shell "defrag"دفراگمنت
Shell "drvspace" فضاي خالي ديسك

اجراي فايل اينترنت با Shell
shell "Explorer.exe"+" http://www.parsiyanpc.iranblog.com.comن به يك سايت
shell "explorer.exe"+" maileto:parsiyan-pc@yahoo.com"كادر ارسال ايميل
shell "explorer.exe"+" yor HTML File.html"كادر اجراي يك فايل اينترنت از حافظه
shell "explorer.exe"+" file://www.سايت شما.com/11.zip"كادردانلود يك فايل از اينترنت

[parsiyan_mohsen]

تنظيم ابعاد نمايش ويندوز براي يك برنامه اختصاصي

برنامه هاي سه بعدي از فضا نمي آيند توسط همين وي بي -دلفي واكثرآ سي پلاس پلاس طراحي مي شن وقتي يك بازي سه بعدي روباز مي كنيم ويك دفعه يك صفحه با گرافيكي كه تا حالا نديديم يه صورت زيبا بالا مي آد اكثر ما -بيشتر خودم- خيلي كف ميكنيم كه اين برنامه ها چطور ساخته مي شن-با چي ساخته مي شن

امروز مي خوام تنظيم ابعاد صفحه نمايش ويندوز رو با ابعاد دلخواه خودمون بگم كه گام اول طراحي سه بعديه اگه بشه شايد مراحل بعديش رو هم بزارم روي سايت كه مونده به ياري شما .بانظراتتون و خدا با توفيقش

ابتدا متغيير هاي اول فرم

Dim Dx As New DirectX7
Dim Dd As DirectDraw4
Dim clip As DirectDrawClipper

البته بعد از نوشتن كد بالا به منوي پروژه رفته گزينه ريفرنس رو انتخاب كنيد در منوي باز شده تيك گزينه ي دايركت ايكس 7 رو بزنيد

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

Set Dd = Dx.DirectDraw4Create("")
Set clip = Dd.CreateClipper(0)
clip.SetHWnd Me.hWnd
' screen mode
Dd.SetDisplayMode 800, 600, 32, 0, DDSDM_DEFAULT

بااين كد صفحه نمايش به مد 800*600و حالت 32بايتي ميره

[parsiyan_mohsen]

كلاس چيست؟؟؟؟

كلاس يك مجموعه اي از كدهاست كه شبيه به يك كنترل هستند فقط شكل ظاهري و طراحي ندارند
كلاس ها شي هستند - يعني خاصيت دارند -كلاس ها مي توانند داخل خود پردازه يا تابع محلي وسراسري داشته باشند
كلاس به چه دردي مي خورد-كلاسها از تكرار كدها جلو گيري مي كنند -كلاس ها خوانايي برنامه را افزايش مي دهندوغيره
كلاس ها مي توانند به صورت خودكار خود را مقدار دهي كنند-يك ماژول كلاس ايجاد كنيد وكدهاي زير را در آن كپي كنيد

تعريف يك خاصيت در كلاس

'-----------Set Property Information---------

Public Poperty Let CWidth( Value As Integer)
CWidth=Value
End Property

'------------Get Property Information--------------

Public Property Get CWidth() As Integer
CWidth=CForm.Width
End Property

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

Private CForm As Form

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

Private Sub CSetInfo(Frm As Form)
Set Form=Frm
End Sub

اگر تمام كدها بالا را درست در يك ماژول كلاس كپي كنيد اكنون نوبت استفاده از كدهاي بالاست
در خط اول فرم يك متغيير از نوع نام كلاس تعريف كنيد.بدين صورت

Dim Calss As Class1
Private Sub Form_Resiz()
Me.Caption="Form1.Width: "& Class.With
End Sub

[parsiyan_mohsen]

چگونه ساعت ديجيتال بسازيم

كوتاهترين راه براي ساخت يك ساعت روش زير است يك Picturebox به فرم اضافه كنيد

Private Sub Form_Load()
Static Score As Long
Counter.Show
DoEvents
Score = 0
For I = 1 To 1265
DisplayNumber 10, Score
Score = I
DoEvents
Next
End Sub'-------------------------------------------------------------------
Private Sub DisplayNumber(DisplayWidth As Integer, TheNumber As Long)
Dim DisplayString As String, Zeros As Integer, GraphicsHeight As Single
Dim DigitValue As Integer, NumPosition As Integer
'--------------------Start Time---------------
GraphicsHeight = Picture1.ScaleHeight / 2
Zeros = DisplayWidth - Len(Trim(TheNumber))
For I = 0 To Zeros - 1
DisplayString = DisplayString & "0"
Next
DisplayString = DisplayString & Trim(Str(TheNumber))
For I = 0 To DisplayWidth - 1
DigitValue = Val(Mid(DisplayString, I + 1, 1))
If DigitValue = 0 Then NumPosition = 10 Else NumPosition = DigitValue _
Counter.PaintPicture Picture1.Image, I * (Picture1.ScaleWidth / 10), 0, _
Picture1.ScaleWidth / 10, Picture1.ScaleHeight / 2, (NumPosition - 1) _
* (Picture1.ScaleWidth / 10), GraphicsHeight, Picture1.ScaleWidth / 10, Picture1.ScaleHeight / 2
Next
End Sub

در كد بالا به دلايلي فرم خارج نمي شود بايد يك دكمه براي خروج از فرم تنظيم كنيدودر كد كليك آن بنوسيد
End

[parsiyan_mohsen]

چطور ميشه يك عكس رو روشنتر كرد يا پر رنگ
Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Byte
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long

Private Sub CmdBrightness_Click()
'variables for brightness, color calculation, positioning
Dim Brightness As Single
Dim NewColor As Long
Dim x, y As Integer
Dim r, g, b As Integer
'change the brightness to a percent
Brightness = TxtBrightness / 100
'run a loop through the picture to change every pixel
For x = 0 To Picture1.ScaleWidth
For y = 0 To Picture1.ScaleHeight
'get the current color value
NewColor = GetPixel(Picture1.hDC, x, y)
'extract the R,G,B values from the long returned by GetPixel
r = (NewColor Mod 256)
b = (Int(NewColor / 65536))
g = ((NewColor - (b * 65536) - r) / 256)
'change the RGB settings to their appropriate brightness
r = r * Brightness
b = b * Brightness
g = g * Brightness
'make sure the new variables aren't too high or too low
If r > 255 Then r = 255
If r < 0 Then r = 0
If b > 255 Then b = 255
If b < 0 Then b = 0
If g > 255 Then g = 255
If g < 0 Then g = 0
'set the new pixel
SetPixelV Picture1.hDC, x, y, RGB(r, g, b)
'continue through the loop
Next y
'refresh the picture box every 10 lines (a nice progress bar effect)
If x Mod 10 = 0 Then Picture1.Refresh
Next x
'final picture refresh
Picture1.Refresh
End Sub

احتياج داريد كه متن درون آن به درصد برابر ميزان روشنايي استTxtBrightnessيك كادر متن به نامCmdBrightnessحال كردين با توضيحات كامل براي كد بالا يك كامند به نام

[parsiyan_mohsen]

چطور مي توان از Desktop عكس گرفت
اين خط رو در اولين خط كد فرم بنويسيد-براي مبتدي ها

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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

طريقه استفاده
Private Sub Form_load()
Dim W, H
W = Screen.Width / 15
H = Screen.Height / 15
StretchBlt hdc, 0, 0, W, H, GetDC(0&), 0, 0, W, H, vbSrcCopy
End Sub

كشيدن يك دايره روي فرم با كد نويسي-نمودار دايره اي-بيضي
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
PI = 3.14159265
For i = 0 To 161 Step 10
Me.Circle (219, 167), i, RGB(0, 0, 0), 360 * (PI / 180), 360 * (PI / 180), 1
Next
End Sub

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

چگونه مي توان يك مداد درست كرد مانند برنامه نقاشي ويندوز
كد زير را در MouseMove بنويسيد
If Button <> vbright Then Me.PSet (X, Y)

چطور مي توان يك قطره چكان درست كرد كه روي هر گزينه رفت رنگ پيش فرض رنگ انجا شود
عكس بنويسيدMouseMoveبه فرم اضافه كنيد يك عكس داخل كادر عكس قرار دهيد و كدزير را در رويدادPictureويكLabelيك

Label1.BackColor=Picture1.Point(X,Y)

چطور مي توان يك عكس را معكوس كرد
منظورت ازمعكوس اگه معكوس خود عكس در طراحي باشه كد زير جوابش هست

With Picture1
.PaintPicture .Picture, 0, .Height, .Width, -.Height
End With

ولي اگه منظورت معكوس رنگ باشه كد زير جوابش هست
With Picture1
.PaintPicture .Picture, 0, 0, , , , , , , vbDstInvert
End With

يراي موقعي به كار مي رود كه از يك اسم زياداستفاده مي كنيم.اسم را جلوي آن مينويسيم وهر وقت يك دات بزنيم قابل استفاده استWithتوضيحات:ِ
پارامتر اول يراي عكسي كه ميخواهيم از آن براي ترسيم استفاده كنيم.دوم و سوم براي نقطه شروع ترسيم .چهارم و پنجم براي اندازه تصوير ترسيمي.ششموهفتم براي نقطه پايان ترسيم.هشتم ونهم براي اندازه هاي پاياني ترسيم وپارامتر آخر براي نوع ترسيم

[parsiyan_mohsen]

کنترل CPU خیلی جالبه

يک فرم ايجاد كنيد و يه هفت تا ليبل بزارين روش با يه تايمر و يه HScroll
خاصيت Max مربوط به اسكرول رو روي 100 بزارين
خاصيت Interval تايمر رو روي 50 بزارين

اين كدها رو اولين خط فرم بنويسيد

'----------Type New Data For Memory------------------
Private Type MEMORYSTATUS
dwlength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type '------------------Declear API Of Kernal Windows Librery-------------
Private Declare Sub GlobalMemoryStatus Lib "KERNEL32" (lpBuffer As MEMORYSTATUS)
Dim Mem As MEMORYSTATUS

روي تايمر دابل كليك كنيد و كد زير را بنويسيد

GlobalMemoryStatus Mem
Me.Caption = Mem.dwMemoryLoad & "% used"
Label1.Caption = "Memory used: " & Mem.dwMemoryLoad & "%"
Label2.Caption = "Total Physical Memory: " & Mem.dwTotalPhys
Label3.Caption = "Available Physical Memory: " & Mem.dwAvailPhys
Label4.Caption = "Page File Bytes: " & Mem.dwTotalPageFile
Label5.Caption = "Available bytes of Page File: " & Mem.dwAvailPageFile
Label6.Caption = "Total Virtual bytes: " & Mem.dwTotalVirtual
Label7.Caption = "Available Virtual Bytes: " & Mem.dwAvailVirtual
HScroll1.Value = Mem.dwMemoryLoad

با كداي بالا مي تونين كاركرد CPU و RAM رو مشاهده كنيد مثل خود ويندوز

[parsiyan_mohsen]

چطور ميتوان سطل آشغال ويندوز رو خالي كرد

اگه بخوايد يك برنامه تقويت ويندوز بنويسيد به گزينه خالي كردن سطل آشغال ويندوز نياز خواهيد داشت
سري قبل اين اموزش رو در مورد كنترل سي پي يو (تاكس منيگر)ويندوز نوشتم
براي اين كار بايد از تابعي موجود در كتابخانه قدرتمند شل كه در آرشيو اموزشهاي زيادي راجع به اين كتابخانه هست استفاده كنيد

شيوه ي تعريف كتابخانه

Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hWnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Const SHERB_NOPROGRESSUI = &H2

شيوه ي استفاده

Private Sub Command1_Click()
Dim retvaL
retvaL = SHEmptyRecycleBin(Form1.hWnd, "", SHERB_NOPROGRESSUI)
End Sub

[parsiyan_mohsen]

چطور مي توان كادر خصوصيات Propertis مربوط به يك فايل را ظاهر كرد

كادر خصوصيات اكثرآ در نوشتن يك كاد آرشيو يا ليست فايل كاربرد دارد كه شما روي نام فايل راست كليك مي كنيد و اين گزينه را معمولآ در انتهاي ليست انتخاب مي كنيد واين كادر ظاهر ميشود نوشتن چنين كد هايي باعث حرفه شدن برنامه ي شما مي گردد

به ماژولمان كد هاي زير را اضافه كنيد

'------Typing New data For Propertis File---------------------
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
'---------------Conset For Propertis Dialog-------------------
Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400
Public Const ATTR_NORMAL = 0
Public Const ATTR_READONLY = 1
Public Const ATTR_HIDDEN = 2
Public Const ATTR_SYSTEM = 4
Public Const ATTR_VOLUME = 8
Public Const ATTR_DIRECTORY = 16
Public Const ATTR_ARCHIVE = 32
'-----------------------Declareing API------------------------------------------
Declare Function ShellExecuteEX Lib "shell32.dll" Alias _
"ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long

'-----------------------------------------------------------------------------------------

Public Function ShowFileProperties(filename As String, OwnerhWnd As Long) As Long
Dim SEI As SHELLEXECUTEINFO
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = OwnerhWnd
.lpVerb = "properties"
.lpFile = filename
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
End With
ShellExecuteEX SEI
ShowFileProperties = SEI.hInstApp
End Function

حالا هر فايلي را كه مي خواهيد خصوصيياتش نمايش داد شود به اين تابع به صورت زير ارسال كنيد-پاس دهيد
ShowFileProperties(FileName,Me.hwnd)

[parsiyan_mohsen]

اموزش یک کار جالب با فرم ها
تنها با دو خط كد ميتونيد جلوه اي رو بوجود بياريد كه فكرشم نمي كرديد. يك فرم رو توي يك فرم ديگه جابديد. استفاده هاي زيادي ميشه ازش كرد. مثلا ساخت نوار ابزارهايي مثل اوني كه فتوشاپ داره. راجع بهش فكر كنيد
اين هم كدش

Private Declare Function SetParent Lib "user32" ( _
ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private Sub Form_Load()
SetParent Form2.hWnd, hWnd
Form2.Show
End Sub

[parsiyan_mohsen]

با اين تابع مي تونيد آيكون هاي روي دسكتاپ رو مخفي و ظاهر كنيد

اول فراخواني توابع

Option Explicit
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

بعد سه تا كامند براي ظاهر كردن آيكون ها مخفي كردن آنها و خروج از فرم بنويسيد

كد هر كدام اينطور است

Private Sub cmdDHide_Click()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 0
End Sub'--------------------------------
Private Sub cmdDShow_Click()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 5
End Sub'---------------------------------
Private Sub cmdExit_Click()
Me.Hide
End
End Sub'-------------------------------------

[parsiyan_mohsen]

مخفي كردن منوي Start
براي مخفي كردن منوي Start به يك تابع از كتابخانه user32.dll احتياج داريد

Option Explicit

Dim hwnd1 As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40

حالا بايد دو تا دكمه براي مخفي و آشكار كردن منوي Startبه فرم اضافه كنيد

كد مخفي كردن Start
Hwnd1=FindWindow("Shell_traywnd","")
call SetWindowPos(Hwnd1,0,0,0,0,0,SWP_HIDEWINDOW)

كد ظاهر كردن Start
call SetWindowPos(Hwnd1,0,0,0,0,0,SWP_SHOWWINDOW)

[parsiyan_mohsen]

با اين برنامه مي تونين دو تا تصوير رو روي هم بندازيد و حركت بدين
تصاويرتون بايد JPG باشه و بزرگ نباشه.دستورات زير رو در قسمت General فرم بنويسيد

Dim Image1 As IPictureDisp
Dim Image2 As IPictureDisp

Private Type Location
X As Integer
Y As Integer
End Type

Dim Image1Move As Integer
Dim Image2MoveX As Integer
Dim Image2MoveY As Integer
Dim Image1Local As Location
Dim Image2Local As Location
Const Operation = vbSrcAnd

دو تا عكس رو در مسير برنامه كپي كنيد اسمشون هم 1 و 2 باشه

كد زير برای Form_Load هست

("Set Image1 = LoadPicture(App.Path & "\Image1.jpg
("Set Image2 = LoadPicture(App.Path & "\Image2.jpg
With me
.Show
Refresh.
.AutoRedraw = True
.ScaleMode = vbPixels
End With

Image1Move = 1
Image2MoveX = 3
Image2MoveY = 3

Do
me.PaintPicture Image1, Image1Local.X, Image1Local.Y
me.PaintPicture Image1, Image1Local.X + me.ScaleWidth, Image1Local.Y
me.PaintPicture Image1, Image1Local.X, Image1Local.Y + me.ScaleHeight
me.PaintPicture Image1, Image1Local.X + me.ScaleWidth, Image1Local.Y + me.ScaleHeight

me.PaintPicture Image2, Image2Local.X, Image2Local.Y, , , , , , , Operation
me.PaintPicture Image2, Image2Local.X + me.ScaleWidth, Image2Local.Y, , , , , , , Operation
me.PaintPicture Image2, Image2Local.X, Image2Local.Y + me.ScaleHeight, , , , , , , Operation
me.PaintPicture Image2, Image2Local.X + me.ScaleWidth, Image2Local.Y + me.ScaleHeight, , , , , , , Operation

With Image1Local
.X = .X - Image1Move
.Y = .Y - Image1Move

If .X < -me.ScaleWidth Then .X = 0
If .Y < -me.ScaleHeight Then .Y = 0
End With

With Image2Local
.X = .X - Image2MoveX
.Y = .Y - Image2MoveY

If .X < -me.ScaleWidth Then .X = 0
If .Y < -me.ScaleHeight Then .Y = 0

If .X + me.ScaleWidth > me.ScaleWidth Then .X = -me.ScaleWidth
If .Y + me.ScaleHeight > me.ScaleHeight Then .Y = -me.ScaleWidth
End With

DoEvents
Loop

براي اينكه دستورات بالا داخل يک حلقه بي پايان قرار مي گيره بايد در رويداد كليك فرم بنويسيد
End

فرم رو زياد بزرگ نكنيد سعي كنيد تصويرها هم اندازه باشند و فرم هم اندازه تصوير ها
براي اينكه در حركت عكس ها تنوع ايجاد كنيم در رويداد MouseMove فرم دستور زير رو بنويسيد

Image2MoveX = Int(me.ScaleWidth \ 2 - X) \ 10
Image2MoveY = Int(me.ScaleWidth \ 2 - Y) \ 10

[parsiyan_mohsen]

بدست آوردن IP و نام سيستم ميزبان

برای امروز قصد دارم يک پروژه ساده را به شما معرفی کنم.

شما ظرف چند دقيقه ميتوانيد اين پروژه را در ويژوال بيسيک بسازيد.

ابتدا ويژوال بيسيک را باز کنيد سپس کنترلر های زير را روی فرم قرار دهيد :

دو عدد TextBox و دو عدد WinSock

حالا روی فرم دو بار کليک کرده و در رويداد لود فرم کدهای زير را وارد کنيد :

Text1.Text = Winsock1.LocalIP
Text2.Text = Winsock2.LocalHostName

برنامه را اجرا کنيد . اين برنامه آی پی و پورت سيستم ميزبان را در اختيار شما قرار ميدهد.

[parsiyan_mohsen]

بستن پنجره با گرفتن عنوان ان

اگر کاربر پنجره ای رو که شما تعیین می کنید رو باز کنه برنامه اون فرم رو می بنده.

در اینجا ما از دو تا تابع API استفاده می کنیم که عبارتند از : FindWindowA برای پیدا کردن پنجره مورد نظر و SetForegroundWindow برای فعال کردن پنجره مورد نظر که هر دوی این توابع در فایل user32.dll تعریف شده اند.

اول برای تعریف توابع فوق خطوط زیر رو در قسمت General وارد کنید :

Private Declare Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Dim Temp As Long

حالا روی فرمتون یه Timer قرار بدین و خاصیت Interval اون رو به 50 تغییر بدید، بعد روی اون دابل کلیک کنید و کد های زیر رو در Sub مربوط به Timer قرار بدین:

Temp = FindWindowA(vbNullString, "My Computer")
If Temp <> 0 Then
SetForegroundWindow (Temp)
SendKeys "%{F4}"
End If

دستور اول هندل ( لازم به ذکر است که سیستم عامل به هر کنترلی و به هر فرمی شماره ای اختصاص می ده که به این شماره میگن هندل) پنجره ای رو که ( در اینجا ) عنوانش My Computer باشد رو در متغیر Temp می ریزد. شرط بعدی چک می کند که پنجره مورد نظر پیدا شده یا نه که در صورت برقراری این شرط با تابع SetForegroundWindow (که آرگومانش همون شماره ای باید باشه که با تابع FindWindowA پیدا کردیم) پنجره پیدا شده رو فعال می کنه و در نهایت تابع SendKeys زهر خودش رو می ریزه و با ارسال یک کلید میانبر به نام Alt+F4 کاربر عزیز رو در باز کردن پنجره مورد نظرش ناکام می کنه!

[parsiyan_mohsen]

ساختن جدول در بانک اطلاعاتی

از منوی project گزینه refrences رو انتخاب کنید - بعد اونجا گزینه Microsoft ActiveX Data Objects 2.0 library پيدا کنيدو تيک بزنيد - Adodc مورد نظرتون رو هم با دیتابیس set کنید - بعد :

Dim db_file As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim NumRec As Integer

Set conn = New ADODB.Connection
conn.ConnectionString = Adodc1.ConnectionString
conn.Open

On Error Resume Next
conn.Execute "DROP TABLE Jadid"
On Error GoTo 0

conn.Execute "CREATE TABLE Jadid(" & "One INTEGER NOT NULL," & "Two VARCHAR(40) NOT NULL," & "Three VARCHAR(40) NOT NULL)"

conn.Execute "INSERT INTO Jadid VALUES (1,'4','7')"
conn.Execute "INSERT INTO Jadid VALUES (2,'5','8')"
conn.Execute "INSERT INTO Jadid VALUES (3,'6','9')"

Set rs = conn.Execute("SELECT COUNT (*) FROM Jadid")
NumRec = rs.Fields(0)

conn.Close

MsgBox "Created ... "

[parsiyan_mohsen]

یک کار جالب با موس

فقط یک تایمر با زمان 500 روی فرم قرار بدین و این کدها رو داخلش کپی کنید
Dim farzadvb
Dim bestforvb6
Dim temp
Randomize 1000

farzadvb = Rnd(10) * 1000

bestforvb6 = Rnd(10) * 1000

temp = SetCursorPos(farzadvb, bestforvb6)

[parsiyan_mohsen]

ضبط صدا به فرمت دلخواه با ویژوال بیسیک

با این برنامه‌ به فرمت دلخواه صدا را ضبط کنید. آن هم به شکلی خیلی ساده.
راه‌های زیادی برای رسیدن به ضبط صدا هست! اما هدف من در اینجا ضبط صدا به فرمت دلخواه است، مثلا mp3 و بدون استفاده از ابزارهای برنامه‌نویسی نظیر ActiveX و ...
ما می‌خواهیم با استفاده از توابع API‌ به این هدف برسیم. توابع در دسترس برای پخش و ضبط صدا عبارتند از mciSendString، mciSendCommand و mciExecute. (برای آشنا شدن با این توابع می‌توانید به سراغ MSDN بروید.)
این توابع هر کدام پیچیدگی خاص خودشان را دارند. مخصوصا اگر قصد ضبط صدا را داشته باشید که باید پارامترهای زیادی را تنظیم کنید که نرخ‌نمونه برداری، تعداد کانال صوتی، بافر و ... را شامل میشوند.
من قصد دارم شما را با تابع mciSendCommand آشنا کنم که با وجود پیچیدگی بیش از حد، استفاده راحت‌تری از آن هم میسر هست و البته به طریقی که آموزش می‌دهم.
بهتر هست با یک مثال شروع کنیم:
شکل کلی این تابع این چنین هست:

Public Declare Function mciSendCommand Lib "winmm.dll" _
Alias "mciSendCommandA" (ByVal wDeviceID As Long, _
ByVal uMessage As Long, _
ByVal dwParam1 As Long, _
ByVal dwParam2 As Any) As Long

پخش فایل صوتی شامل چند مرحله است:
1- باز کردن فایل صوتی
2- دستور پخش
3- بستن فایل (که حتما باید انجام بشه)
باز کردن فایل صوتی خود شامل پارامترهایی است که در ساختار زیر مشخص میشود:

Private Type MCI_OPEN_PARMS
dwCallback As Long
wDeviceID As Long
lpstrDeviceType As String
lpstrElementName As String
lpstrAlias As String
End Type

البته باید ذکر کنم که برخی پارامترها در شرایط خاصی مقدار دهی می‌شوند تا کار مشخصی را انجام دهند (پارامتر سوم، بعدا مثال میآرم)
کد زیر یک فایل صوتی را باز می‌کند و هندل آن را در صورت موفقیت جایی نگه می‌داریم، چون از این به بعد ما با این هندل خیلی کار داریم.
پارامتر آخر از تابع mciSendCommand حاوی ساختار مرتبط با نحوه عمل است.

Dim dwReturn As Long
Dim mciOpenParms As MCI_OPEN_PARMS
'Open a waveform-audio device with filename for play.
mciOpenParms.lpstrDeviceType = "WaveAudio"
mciOpenParms.lpstrElementName = filename dwReturn = mciSendCommand(0, MCI_OPEN, _
MCI_OPEN_ELEMENT Or MCI_OPEN_TYPE, _
mciOpenParms)
If dwReturn Then
MsgBox "Failed to open device; don't close it, just return error."
Exit Sub
End If 'The device opened successfully; get the device ID.
wDeviceID = mciOpenParms.wDeviceID

و برای پخش از کد زیر استفاده می‌کنیم که بعد از کد باز کردن فایل میگذاریم:

dwReturn = mciSendCommand(wDeviceID, MCI_PLAY, 0, vbNull)
If dwReturn Then
mciSendCommand wDeviceID, MCI_Close, 0, vbNull
MsgBox "MCI_PLAY not succed!"
Exit Sub
End If

اگر دقت کنید پارامتر سوم مقدار صفر را داراست. این پارامتر می‌تواند به نحوی مشخص شود که با اجرای دستور پخش، کنترل به برنامه داده شود یا تا زمانی که پخش به اتمام نرسیده برنامه منتظر بماند. و مشخه‌های دیگر.
چون ذکر نکردیم پس کنترل برنامه را در حین پخش در دست می‌گیریم.
و سرانجام با این کد فایل را می‌بندیم:

Dim dwReturn As Long dwReturn = mciSendCommand(wDeviceID, MCI_Close, MCI_WAIT, vbNull)
If dwReturn Then
mciSendCommand wDeviceID, MCI_Close, 0, vbNull
MsgBox "MCI_Close not succed!"
Exit Sub
End If

و اما ضبط صدا. برای ضبط باید از ساختار پیچیده زیر استفاده کنیم:

Private Type MCI_WAVE_SET_PARMS
dwCallback As Long
dwTimeFormat As Long
dwAudio As Long
wInput As Long
wOutput As Long
wFormatTag As Integer
wReserved2 As Integer
nChannels As Integer
wReserved3 As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wReserved4 As Integer
wBitsPerSample As Integer
wReserved5 As Integer
End Type

برای یک ضبط ساده باید این همه پارامتر را مقدار دهی کنید و تازه ممکن است صدا بر اساس مقادیر اشتباه بی کیفیت و نامطلوب ضبط شود.
از همه اینها که بگذریم قصد من این بود تا ترفندی را به شما آموزش بدهم که خیلی راحت صدا را به هر فرمتی که خواستید ضبط کنید.

.:: CODEC ::.
این کلمه مخفف واژه‌های COmpress/DECompress هست و به زبان ساده‌تر درایوری است که عمل کدسازی و دیکودسازی اطلاعات را انجام می‌دهد، البته برای کاربر محسوس نیست و به نوعی در پشت پرده انجام می‌گیرد.
وقتی شما فایلهای wav را در سیستم پخش می‌کنید، باید codec فایلهای wav در سیستم نصب شده باشد وگرنه قادر به پخش نیستید که البته بهمراه ویندوز این درایورها نصب میشوند.
برای فایلهای mp3 نیز همین قضیه صادق هست و غیره.
برای اینکه بدانید بر روی سیستم شما چه codecهایی نصب شده مراحل زیر را دنبال کنید:

Control Panel -> Sound & Audio Device -> Hardware -> select Audio Codec from list -> click on Properties.

با این توضیحاتی که آمد می‌خواهیم بر اساس یکی از codecهای نصب شده اقدام به ضبط صدا کنیم.
لازم به ذکر است که برخی codecها فقط حاوی بخش پخش هستند و امکان ضبط رو ندارند!
برسیم به هدف اصلی از این صحبت‌ها.

1- Sound Recorder ویندوز رو باز کنید و سپس از منوی File گزینه Save As...‌ را انتخاب کنید.
2- دکمه Change را کلیک کنید تا لیست codec ها ظاهر شود.
3- گزینه Format را با codecی که می‌خواهید تنظیم کنید.
4- OK کنید و بعد نام فایل را مشخص کنید و Save‌ نمائید.

با طی این 4 مرحله شما یک فایل صوتی ساختید که فقط حاوی تنظمیات صدا است. یعنی تمام پارامترهای ساختار MCI_WAVE_SET_PARMS

حالا اگر با تابع mciSendCommand‌ این فایل را باز کنید و اقدام به ضبط صدا نمائید، در واقع دارید به فرمتی که می‌خواهید صدا را ضبط می‌کنید و درگیر تنظیمات خاصی نیستید.
سورسی را که مربوط به همین بخش است، این صحبت‌ها را پیاده‌سازی کرده و نمونه کاملی از ضبط و پخش به فرمت دلخواه را انجام می‌دهد.
و این نکته که دو فایل با پسوند mrf در کنار برنامه هست، در واقع فایل‌های حاوی ساختار هستند(wav)‌ که پسوندشان عوض شده.

برنامه ابتدا لیست تمام فایلهای با پسوند mrf‌ را لیست می‌کند و در هنگام ضبط به همان فرمتی که انتخاب می‌کنید اقدام به ضبط می‌کند.
شما می‌توانید هر ساختاری را که دوست داشتید با Sound Recorder بسازید و با پسوند mrf در کنار برنامه ذخیره کنید و از نزدیک با چگونگی عمل ضبط آشنا شوید.

[parsiyan_mohsen]

چگونه وقفه ايجاد کنيم : مثلا برای بارگذاری فرم

Sub Pause(interval)
Dim Current
Current = Timer
Do While Timer - Current < Val(interval)
DoEvents
Loop
End Sub

*******************************
بيل گيتس : جهاني فكر كنيد؟ محلي عمل كنيد!

[parsiyan_mohsen]

برنامه خاموش کردن Windows با يک کليک
در اين برنامه يک پروژه ساده رو به شما معرفی ميکنم که در اون با يک کليک ساده دکمه ميتوانيد ويندوز رو
خاموش کنيد . برای ساخت اين پروژه مراحل زير را طی کنيد :
۱ - ويژوال بيسيک را باز کنيد
۲ - يک فرم جديد ايجاد کنيد
۳ - از جعبه ابزار ويژوال يک دکمه روی فرم قرار دهيد
۴ - روی دکمه دو بار کليک کرده و دستور زير را در رويداد کليک دکمه تایپ کنيد

Shell ("Shutdown ") ' Shuts computer down

همانطور که ديده ميشود در صورت اجرای و فشار دکمه ويندوز خاموش ميشود.
اين دستور دارای سويچ های خاص ميباشد که ميتوانيد در برنامه خود استفاده کنيد . در زير اين
سويچ ها ارائه شده اند :

' Switches:
l Log off profile
s Shut down computer
r Restart computer
f Force applications to close
t Set a timeout for shutdown
m \\computer name Shut down remote computer
i Show the Shutdown GUI

مثال :

Shell ("Shutdown -s -t 5") ' Shuts computer down after timeout of 5

بعنوان مثال در صورت استفاده از فرمان فوق سيستم بعد از 5 ثانيه خاموش ميشود. دقيقا مطابق کدی
که در ويروس ام اس بلستر استفاده شده با اين تفاوت که مدت انتظار برای خاموش شدن سيستم در
اين ويروس 30 ثانيه است

[parsiyan_mohsen]

یه ترفند جالب در visual Basic 6

ابتدا از منوی View گزینه Toolbar و سپس customaize رو انتخاب کنید

سپس تب commands رو انتخاب کنید و از لیست زیرین Help رو انتخاب کنید و سپس از لیست روبرو گزینه About microsoft visual basic رو

درگ کنید روی تولبار اصلی برنامه و رهاش کنید و سپس روی او راست کلیک کنید و در قسمت نام عبارت Show VB Credits را وارد کنید و بعد

پنجره customaize رو ببندید و و روی دکمه کلیک کنید و لذت ببرید

[sina_saravi1]

AnimateWindow
اين تابع رو بايد در حالتي كه يه پنجره هنوز رسم نشده(يا Hide هست و ...) و يا قبل از پنهان شدن هست بايد فراخواني كرد
بعد از فراخواني تابع پنجره در حالتهاي مختلف به صورت انيميت رسم ميشه يا پنهان ميشه.مثلا از سمت چپ طولش افزايش پيدا ميكنه تا كاملا رسم بشه.اين تابع توي API Viewer نيست:

Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean

ثابت هاي مورد نياز:

Const AW_HOR_POSITIVE = &H1
Const AW_HOR_NEGATIVE = &H2
Const AW_VER_POSITIVE = &H4
Const AW_VER_NEGATIVE = &H8
Const AW_CENTER = &H10
Const AW_HIDE = &H10000
Const AW_ACTIVATE = &H20000
Const AW_SLIDE = &H40000
Const AW_BLEND = &H80000

اين تابع 3 تا مقدار به صورت byVal ميگيره.اول هندل پنجره مورد نظر.دومي زماني كه ميخواهيم عمل رسم انجام بشه سومي هم روش رسم هست كه بايد ثابت ها را به اين بديم.بعضي از مقادير (آخر) رو ميشه از طريق Or با هم استفاده كرد.
موقتي كه ميخواهيم يك پنجره از حالت رسم شده به حالت پنهان بره بايد مقدار AW_HIDE رو هم به پارامتر آخر (با استفاده از Or) اضافه كنيد.كارهايي كه اين ثابت ها ميكنن:

AW_HOR_POSITIVE پنجره از چپ به راست رسم يا پاك ميشه
AW_HOR_POSITIVE پنجره از راست به چپ رسم يا پاك ميشه
AW_VER_POSITIVE پنجره از بالا به پايين رسم يا پاك ميشه
AW_VER_NEGATIVE پنجره از پايين به بالا رسم يا پاك ميشه
AW_CENTER پنجره از مركز باز ميشه يا بالعكس
AW_ACTIVATE پنجره رو فعال ميكنه

بقيه رو هم درست نفهميدم شما هم امتحان كنين.
يه مثال ميزنم.2 تا دكمه داخل فرم درست كنين و كد زير رو وارد كنين:

Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean
Const AW_HOR_POSITIVE = &H1
Const AW_HOR_NEGATIVE = &H2
Const AW_VER_POSITIVE = &H4
Const AW_VER_NEGATIVE = &H8
Const AW_CENTER = &H10
Const AW_HIDE = &H10000
Const AW_ACTIVATE = &H20000
Const AW_SLIDE = &H40000
Const AW_BLEND = &H80000
Private Sub Form_Load()
Me.BackColor = vbBlue
AnimateWindow Me.hwnd, 1000, AW_HOR_POSITIVE Or AW_VER_NEGATIVE
Me.Cls
End Sub
Private Sub Command1_Click()
If Command2.Visible = True Then
AnimateWindow Command2.hwnd, 1000, AW_CENTER Or AW_HIDE: Command2.Visible = False
Else
AnimateWindow Command2.hwnd, 1000, AW_CENTER: Command2.Visible = True
End If
End Sub

براي اينكه بعد از رسم تغيير رنگ هاي(احتمالي) ايجاد شده از بين بره(صفحه پاك بشه) از Me.Cls استفاده كردم.
اين رو هم بگم كه در زماني كه تابع داره كارشو ميكنه برنامه كار ديگه اي نميتونه بكنه.در ضمن رنگ زمينه رو عوض كردم تا تغيير اندازه دكمه مشخص بشه.ديگه فكر نكنم توضيحي بخواد.

سلام

تو این پست یه سری از متنها تکراریه
مثله


AW_HOR_POSITIVE پنجره از چپ به راست رسم يا پاك ميشه
AW_HOR_POSITIVE پنجره از راست به چپ رسم يا پاك ميشه

اگه میشد تو موضوع پیدا کردن هندل تکست باکس پنجره ی چت یاهو کمکم کنید واقعا ممنون میشدم

[relax_cp]

parsiyan_mohsen (http://barnamenevis.org/forum/member.php?u=105519) عزيز دستت درد نكنه . خيلي از مشكلات منو حل كرديد.
اگه مي شه يه سري هم به تاپيك http://barnamenevis.org/forum/showthread.php?t=166869 و همچنين http://barnamenevis.org/forum/showthread.php?t=166504 بزنيد . مطمئن هستم جواب خوبي براي اين ها داريد.
ممنون

[butterfly8528]

parsiyan_mohsen عزیز بابت زحمتی که میکشی ممنون .

لطفا برای حفظ نظم تاپیک و جلوگیری از به هم ریخته شدن کد ها ، کد ها رو داخل تگ کد قرار بده . :چشمک:

[parsiyan_mohsen]

چشم دوست عزیز به روی چشمام....:چشمک:
حالا باقیشو هم شروع میکنم....

[parsiyan_mohsen]

با کد زیر می تونید ماوس و کیبورد را به مدت 10 ثانیه قفل کنید .

کد زیر را در یک فرم کپی کنید.

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()

DoEvents
'block the mouse and keyboard input
BlockInput True
'wait 10 seconds before unblocking it
Sleep 10000
'unblock the mouse and keyboard input
BlockInput False
End Sub

[parsiyan_mohsen]

با کد زیر دیگه نیاز نیست یه عالمه API به برنامه اضافه فقط کافی نام API را بلد باشید به کد زیر یک نگاه بندازید!

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long


Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long


Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long


Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long


Private Sub Form_Load()

Dim Libary As Long
Dim PrcAdress As Long
On Error Goto NoApi
'Load the Libary
Libary = LoadLibrary("user32")
'Find the procedure we want
Procadress = GetProcAddress(Libary, "MessageBoxA")
'Call the Api
CallWindowProc Procadress, Me.hWnd, "My Message", "Api without Declare", &H0&
'Unload the libary
FreeLibrary Libary
NoApi:
End Sub

[parsiyan_mohsen]

با کد زیر می تونید رنگهای RGB را به Hex تبدیل کنید و Hex را به رنگ. این کد بدرد کسانی می خوره که از برنامه های یاهو استفاده می کنند. چون رنگ های موجود در یاهو به صورت HEX هست.

Public Function rgbtohex(r As Byte, g As Byte, b As Byte)
'input format = 255,255,255
'get the r value
If r < 16 Then
hex1 = 0 & Hex(r)
Else
hex1 = Hex(r)
End If

'get the g value
If r < 16 Then
hex2 = 0 & Hex(g)
Else
hex2 = Hex(g)
End If

'get the b value
If b < 16 Then
hex3 = 0 & Hex(b)
Else
hex3 = Hex(b)
End If

rgbtohex = "#" & hex1 & hex2 & hex3
End Function


Public Function RGBtoColor(r As Byte, g As Byte, b As Byte)
RGBtoColor = r + (g * 256) + (b * 65536)
End Function


Public Function colortorgb(color As Long)
Dim r, g, b As Byte
r = color And 255
g = (color \ 256) And 255
b = (color \ 65536) And 255
colortorgb = r & "," & g & "," & b
End Function

[parsiyan_mohsen]

اینم از کد برای چک کردن فولدر ها امیدوارم نهایت لذت رو برده باشید.
یک Command1 به فرم اضافه کنید.

Sub Command1_Click ()
f$ = "C:\WINDOWS"
dirFolder = Dir(f$, vbDirectory)


If dirFolder <> "" Then
strmsg = MsgBox("This folder already exists.", vbCritical):goto optout
End IF
End Sub

[parsiyan_mohsen]

عوض کردن آدرس اینترنتی در اینترنت اکسپلورر فقط با دو خط :

Set wshshell = CreateObject("WScript.Shell")
wshshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Start Page", "http://www.Micro-TC.Blogfa.com"

[parsiyan_mohsen]

این کد کارش چک کردن فایل هست که آیا فایلی از قبل وجود داشت یا نه ؟ فکر کنم بدرد کسانی می خوره که کارشون ذخیره فایل های Txt یا عکس هست.

Private Function FileExists(FullFileName As String) As Boolean

On Error Goto MakeF
'If file does Not exist, there will be an Error
Open FullFileName For Input As #1
Close #1
'no error, file exists
FileExists = True
Exit Function
MakeF:
'error, file does Not exist
FileExists = False
Exit Function
End Function

Sub Command1_Click ()
msgbox FileExists
End Sub

[parsiyan_mohsen]

اینم از یک کد دیگه که کارش اینه فایل ها و فولدر های موجود در یک فولدر را براحتی پاک می کنه فقط با چند خط کد نویسی .
یک Command1 به برنامه اضافه کنید و بعد کد زیر را کپی کنید.

Public Sub DelAll(ByVal DirtoDelete As Variant)

Dim FSO, FS
Set FSO = CreateObject("Scripting.FileSystemObject")
FS = FSO.DeleteFolder(DirtoDelete, True)
End Sub

'so like

Private Sub Command1_Click()

Call delall("c:\New Folder")
'that would delete the c:\New Folder
End Sub

[parsiyan_mohsen]

سلام امروز یک کد بسیار ساده برای شما آماده کردم. کد زیر باعث میشه فقط برنامه برای 25 اجرا بشه نه بیشتر یک command1 به فرم اظافه کنید و بعد کد زیر را به برنامه اظافه کنید.

Private Sub Form_Load()

' the "A" in getsetting and savesetting
' can be changed to another letter
retvalue = GetSetting("A", "0", "RunCount") ' this returns the value of the registry edit.
Worm$ = Val(retvalue) + 1 ' adds one To the value of the regisrty edit.
SaveSetting "A", "0", "RunCount", Worm$ ' saves the new value


If Worm$ < 25 Then 'put one number higher then it says.
' this is the popup to warn the user how
' many runs have been executed and how man
' y are left.
MsgBox "you have used this program " & Worm$ & " Times. Only " & (25 - Worm$) & " left."
End If

' this is the statement to check whether
' to execute the form load or end program


If Worm$ > 24 Then 'put one number lower then it says.
MsgBox "you have used this program 25 Times, purchase is now required", 16, "Sorry"
' this would send the user to a website
' in their default browser.
Win32Keyword "http://skygazer.net"
Unload Me
End
End If

End Sub



Private Sub Command1_Click()

End
End Sub

به نظرم خیلی داغه حتماً ازش استفاده کنید:چشمک:

[parsiyan_mohsen]

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

یک TextBox با نام Text1 به فرم اظافه کنید.

For a = 0 To List1.ListCount - 1 'Start Loop
List1.Selected(a) = True 'Select part of list
Text1.Text = Text1.Text & List1.Text & " " 'Add selected part of list To text
Next 'End Loop

[parsiyan_mohsen]

چاپ به صورت باینری...
دیگه لازم نیست توضیح بدم :

Public Sub PrintBinary(Num As Long)
Dim j&, i&
j = 128
For i = 8 To 1 Step -1
If (Num And j) = 0 Then
Debug.Print "0";
Else
Debug.Print "1";
End If
j = j / 2
Next
End Sub

[parsiyan_mohsen]

طراحی آسان در ویژوال بیسیک :
خوب با چند تا کد کوتاه زیر می تونید در وِیژوال بیسیک طراحی کنید. یک پروژه ایجاد کنید و روی فرم دابل کلیک کنید کد های زیر را توش کپی کنید.




Private A As Integer: Private B As Integer
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
A = X: B = Y
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Form1.Line (A, B)-(X, Y)
A = X: B = Y
End If
End Sub

[parsiyan_mohsen]

با این کد می تونید یک فایل txt را بصورت خط به خط بخونید . اگه حجم فایل زیاد باشه کمی طول میکشه ولی با این می تونید خیلی کار ها بکنید، بدردتون میخوره.




Sub ReadLineByLine()

' Variable Declarations
Dim folderName As String
Dim fileName As String
folderName = "C:\Dump\"
fileName = "test.txt"
Open folderName & fileName For Input As #1


Do While Not EOF(1)
Line Input #1, inputdata
MsgBox inputdata ' or txtFile.Text = TxtFile.Text + vbcrlf + Input Data
Loop

Close #1
End Sub

[parsiyan_mohsen]

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




Public Sub SunkenPanel3D(obj As Object)

' Gives the effect of sinking the entire
'
' form or picture box, much like a 3d pi
' cture
' box with border style set to 1 - Fixed
' Single
' Hold the original scale mode
Dim nScaleMode As Integer
' Used for user defined scale only
Dim sngScaleTop As Single
Dim sngScaleLeftAs Single
Dim sngScaleWidthAs Single
Dim sngScaleHeight As Single


If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then

nScaleMode = obj.ScaleMode



If nScaleMode = 0 Then ' user defined scale
sngScaleTop = obj.ScaleTop
sngScaleLeft = obj.ScaleLeft
sngScaleWidth = obj.ScaleWidth
sngScaleHeight = obj.ScaleHeight
End If

obj.ScaleMode = 3 ' Pixel
obj.Line (2, 2)-(obj.ScaleWidth - 1, 2), vb3DDKShadow
obj.Line (2, 2)-(2, obj.ScaleHeight - 1), vb3DDKShadow
obj.Line (2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, obj.ScaleHeight - 2), vb3DHighlight
obj.Line (obj.ScaleWidth - 2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 2, 1), vb3DHighlight

' Set the scale mode back to the same as
' it was
obj.ScaleMode = nScaleMode


If nScaleMode = 0 Then
obj.ScaleTop = sngScaleTop
obj.ScaleWidth = sngScaleWidth
obj.ScaleLeft = sngScaleLeft
obj.ScaleHeight = sngScaleHeight
End If

End If

End Sub

Public Sub RaisedPanel3D(obj As Object)

' Gives the effect of raising the entire
'
' picture box. Much like a 3d Panel
' Hold the original scale mode
Dim nScaleMode As Integer
' Used for user defined scale only
Dim sngScaleTop As Single
Dim sngScaleLeftAs Single
Dim sngScaleWidthAs Single
Dim sngScaleHeight As Single


If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then

nScaleMode = obj.ScaleMode



If nScaleMode = 0 Then ' user defined scale
sngScaleTop = obj.ScaleTop
sngScaleLeft = obj.ScaleLeft
sngScaleWidth = obj.ScaleWidth
sngScaleHeight = obj.ScaleHeight
End If

obj.ScaleMode = 3 ' Pixel
obj.Line (1, 1)-(obj.ScaleWidth - 1, 1), vb3DHighlight
obj.Line (1, 2)-(1, obj.ScaleHeight), vb3DHighlight
obj.Line (1, obj.ScaleHeight - 1)-(obj.ScaleWidth, obj.ScaleHeight - 1), vb3DShadow
obj.Line (obj.ScaleWidth - 1, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, 1), vb3DShadow

' Set the scale mode back to the same as
' it was
obj.ScaleMode = nScaleMode


If nScaleMode = 0 Then
obj.ScaleTop = sngScaleTop
obj.ScaleWidth = sngScaleWidth
obj.ScaleLeft = sngScaleLeft
obj.ScaleHeight = sngScaleHeight
End If

End If

End Sub

Public Sub Raised3D(obj As Object)

' Gives the effect of a raised line arou
' nd
' the form or picturebox
' Hold the original scale mode
Dim nScaleMode As Integer
' Used for user defined scale only
Dim sngScaleTop As Single
Dim sngScaleLeftAs Single
Dim sngScaleWidthAs Single
Dim sngScaleHeight As Single


If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then

nScaleMode = obj.ScaleMode



If nScaleMode = 0 Then ' user defined scale
sngScaleTop = obj.ScaleTop
sngScaleLeft = obj.ScaleLeft
sngScaleWidth = obj.ScaleWidth
sngScaleHeight = obj.ScaleHeight
End If

obj.ScaleMode = 3 ' Pixel
obj.Line (1, 1)-(obj.ScaleWidth - 1, 1), vb3DHighlight
obj.Line (1, 2)-(obj.ScaleWidth, 2), vb3DShadow
obj.Line (1, 2)-(1, obj.ScaleHeight), vb3DHighlight
obj.Line (2, 2)-(2, obj.ScaleHeight), vb3DShadow
obj.Line (1, obj.ScaleHeight - 2)-(obj.ScaleWidth, obj.ScaleHeight - 2), vb3DHighlight
obj.Line (1, obj.ScaleHeight - 1)-(obj.ScaleWidth, obj.ScaleHeight - 1), vb3DShadow
obj.Line (obj.ScaleWidth - 2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 2, 1), vb3DHighlight
obj.Line (obj.ScaleWidth - 1, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, 1), vb3DShadow

' Set the scale mode back to the same as
' it was
obj.ScaleMode = nScaleMode


If nScaleMode = 0 Then
obj.ScaleTop = sngScaleTop
obj.ScaleWidth = sngScaleWidth
obj.ScaleLeft = sngScaleLeft
obj.ScaleHeight = sngScaleHeight
End If

End If

End Sub



Public Sub Etched3D(obj As Object)

' Gives the effect of an eteched line ar
' ound the
' form or picture box.
' Hold the original scale mode
Dim nScaleMode As Integer
' Used for user defined scale only
Dim sngScaleTop As Single
Dim sngScaleLeftAs Single
Dim sngScaleWidthAs Single
Dim sngScaleHeight As Single

If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then

nScaleMode = obj.ScaleMode

If nScaleMode = 0 Then ' user defined scale
sngScaleTop = obj.ScaleTop
sngScaleLeft = obj.ScaleLeft
sngScaleWidth = obj.ScaleWidth
sngScaleHeight = obj.ScaleHeight
End If

obj.ScaleMode = 3 ' Pixel
obj.Line (1, 1)-(obj.ScaleWidth - 1, 1), vb3DShadow
obj.Line (1, 2)-(obj.ScaleWidth, 2), vb3DHighlight
obj.Line (1, 2)-(1, obj.ScaleHeight), vb3DShadow
obj.Line (2, 2)-(2, obj.ScaleHeight), vb3DHighlight
obj.Line (1, obj.ScaleHeight - 2)-(obj.ScaleWidth, obj.ScaleHeight - 2), vb3DShadow
obj.Line (1, obj.ScaleHeight - 1)-(obj.ScaleWidth, obj.ScaleHeight - 1), vb3DHighlight
obj.Line (obj.ScaleWidth - 2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 2, 1), vb3DShadow
obj.Line (obj.ScaleWidth - 1, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, 1), vb3DHighlight

' Set the scale mode back to the same as
' it was
obj.ScaleMode = nScaleMode


If nScaleMode = 0 Then
obj.ScaleTop = sngScaleTop
obj.ScaleWidth = sngScaleWidth
obj.ScaleLeft = sngScaleLeft
obj.ScaleHeight = sngScaleHeight
End If

End If


End Sub

[parsiyan_mohsen]

با سه خط زیر می تونید یک فایل WAV را اجرا و قطع کنید بدون نیاز به هیچ گونه کد اضافی و هیچگونه dll , ocx.

کد زیر را به فرم خود اظافه کنید.

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10

'----------PLAY WAVE SOUND--------

Private Sub PlayWaveSound_Click()

soundfile$ = "c:/TheCustomSoundIWant.wav"
wFlags% = SND_ASYNC Or SND_NODEFAULT
HaHa = sndPlaySound(soundfile$, wFlags%)
End Sub

'-------STOP WAVE SOUND-------

Private Sub StopTheSound_Click()
StopTheSoundNOW = sndPlaySound(soundfile$, wFlags%)
End Sub
'Replace "c:/TheCustomSoundIWant.wav" wi
' th your sound

[parsiyan_mohsen]

نمایش فولدرها به صورت درختی








Public Sub eRoot(rootpath As String, fldrs As Boolean
On Error Resume NextDim EX, ARGU, path, X
If fldrs = True Then
EX = "explorer.exe"
ARGU = " /e,/root, "
path = rootpath$
X = Shell(EX & ARGU & path, 1)
ElseIf fldrs = False Then
EX = "explorer.exe"
ARGU = " n/e,/,root, "
path = rootpath$
X = Shell(EX & ARGU & path, 1)
End IF
End Sub

[parsiyan_mohsen]

شاید تا حالا دیده باشید که وقتی داریم با jetaudio فیلم نگاه می کنیم اشاره گر بعد از چند ثانیه غیب میشه ! خیلی جالبه نه ؟



* قبل از این کار دو تا دگمه با نام Command1 و Command2 به برنامه خودتون اظافه کنید.




Declare Function ShowCursor& Lib "user32" _
(ByVal bShow As Long)


Private Sub Command1_Click()

ShowCursor (bShow = True)
End Sub


Private Sub Command2_Click()

ShowCursor (bShow = False)
End

[parsiyan_mohsen]

بازم واستون میزارم. :تشویق:

[parsiyan_mohsen]

اینو میزارم چون در موردش کم دیدم و شاید بعضی های بلد نباشن و بخوان یاد بگیرن :

گزارش گیری از پایگاه داده در ویژوال بیسیک


» همانطور که شما عزیزان می دانید گزارشگیری می تواند یکی از ویژگیهایی باشد که یک برنامه پایگاه داده را کاملتر و قابل استفاده تر می کند و کاربران به استفاده از این نوع برنامه ها رغبت بیشتری دارند . یعنی به طور کلی امکان گزارشگیری در یک برنامه از مهمترین ویژگیهای آن است . از گزارشگیری بیشتر در چاپ استفاده می شود و کاربر می تواند قبل از چاپ اطلاعاتی را مشاهده و ارزیابی کند . در این درس من روش ساخت گزارش معمولی با استفاده از امکانات آماده خود ویژوال بیسیک را توضیح خواهم داد ، ولی اکتیوایکس های پیشرفته تری مانند کریستال ریپورت ( Crystal Report ) که توانایی ساخت گزارشهای جالبتر و بهتری را دارند نیز وجود دارند که خود شما باید پیگیر آنها باشید .


» قبل از شروع ساخت گزارش شما باید چند نکته در این مورد یاد بگیرید . در ایجاد یک گزارش معمولی ویژوال بیسیک از از رابط OLE DB برای برقراری ارتباط با پایگاه داده مورد نظر استفاده می کند . برای شروع شما VB خود را باز کرده و یک پروژه استاندارد ایجاد کنید . سپس برای ایجاد رابط از منوی Project گزینه Add Data Environment را انتخاب کنید . با زدن این گزینه فرمی به صورت زیر ایجاد می شود :

http://www.mediavb.persiangig.com/Data%20Base/9.JPG






» همانطور که در تصویر می بینید این فرم از یک لیست درختی تشکیل شده که سر شاخه آن همان نام رابط است . شاخه Connections لیست ارتباطها با پایگاه داده ها را مشخص می کند . مثال Connection1 با یک پایگاه داده مرتبط است و حال این که Connection بعدی که ایجاد میکنید می تواند با یک پایگاه داده دیگر ارتباط برقرار کند . شاخه Commands هم جدول یا جدول های انتخابی از هر پایگاه داده را مشخص میکند که بیشترین کاربرد را دارد . حال به توضیح هر یک از این دو شاخه می پردازیم :


شاخه Connections : همانطور که گفته شد این ابزار یا شی ء پایگاه داده ای را که قرار است از آن گزارش تهیه شود مشخص می کند . برای مثال ما مراحل انتخاب یک پایگاه داده مراحل زیر را دنبال می کنیم :


1 ) روی Connection1 راست کلیک کنید تا منویی باز شود . از این منو گزینه Properties را انتخاب کنید تا دیالوگ Data Link Properties نمایش داده شود . برگه اول این دیالوگ دارای یک لیست است.



2 ) شما از این لیست گزینه Microsoft Jet 4.0 OLE DB Provider را انتخاب کرده و گزینه Next را بزنید تا برگه دوم این دیالوگ نمایش داده شود .


3 ) در این مرحله پایگاه داده مورد نظر خود را انتخاب کنید . برای آگاهی از این که آیا اتصال به درستی انجام گرفته می توانید از دکمه Test Connection استفاده کنید . سپس دکمه OK را برای پایان این مرحله انجام دهید .

با انجام این مراحل ما توسط Connection1 به پایگاه داده مورد نظر خود متصل شدیم . حال زمان استفاده از شی ء Command است . برای ایجاد یک Command برای Connection1 روی Connection1 کلیک راست کرده و گزینه Add Command را بزنید . با این کار Command1 به لیست Command ها اضافه خواهد شد .

شاخه Commands : همانطور که گفته شد شی Command برای مدیریت جدول یا فیلد ها استفاده می شود . برای تنظیم این شی ء مراحل زیر را دنبال می کنیم :

1 ) روی Command1 کلیک راست کرده و گزینه Properties را انتخاب کنید تا دیالوگ زیر نمایش داده شود :

http://www.mediavb.persiangig.com/Data%20Base/10.JPG





در این دیالوگ اصلی ترین قسمت برگه General است که ما باید آن را تکمیل کنیم .


2 ) در برگه General از کشوی DataBase Objects گزینه Table را انتخاب کنید تا در کشوی Object Name نام جدول های موجود در پایگاه داده قرار گیرد و شما جدول مورد نظر خود را انتخاب کنید . حتی شما می توانید با استفاده از دستورات SQL که در قسمت SQL Statement می نویسید جدول مورد نظر خود را انتخاب نمایید .


3 ) سپس دکمه Apply و دکمه Ok را برای تکمیل این قسمت فشار دهید . برگه های دیگر این دیالوگ برای ساخت گزارشهای پیشرفته تر کاربرد دارند که ما از تکمیل این قسمت ها را به خود شما عزیزان واگزار می کنم .


» در این قسمت تنظیمات مربوط به رابط پایگاه داده به پایان رسید . حال برای ایجاد صفحه طراحی گزارش از منوی Project گزینه Add Data Report را انتخاب کنید . یک صفحه طراحی گزارش با جعبه ابزار مخصوص با نام Data Reprot1 در اختیار شما قرار داده می شود . در این قسمت دو روش برای طراحی گزارش وجود دارد :


روش اول این است که خود شما برای هر کدام از فیلدهایی که می خواهید در گزارش قید شوند یک Rpt Text Box و Rpt Lable قرار دهید و خواص هر کدام از آنها را به طور جداگانه تنظیم کنید .


روش دوم این است که فرم رابط یا Data Environment و DataReport1 را به صورت زیر قرار داده و با کشیدن و انداخت هر کدام از فیلد ها و یا کل جدول از فرم رابط بر روی فرم گزارش ، گزارش خود را تنظیم کنید .

مهم ترین قسمت : مهمترین قسمت این بخش مرتبط کردن فرم گزارش با فرم رابط است . برای این کار شما باید خواص DataReport1 یا همان فرم گزارش خود را به صورت زیر تنظیم کنید :



1 ) خاصیت DataSource را برابر با DataEnvironment1 قرار دهید .

2 ) خاصیت DataMember را برابر با Command1 قرار دهید .



حال گزارش شما برای نمایش آماده است . برای این کار شما باید در Form1 خود یک CommandButton قرار داده و کد زیر را در آن بنویسید :



()Private Sub Command1_Click
DataReport1.Show

End Sub
همچنین شما می توانید برای فرم گزارش خود سر برگ یا شماره صفحه و چیز های دیگر قرار دهید . همچنین می توانید برای آن منو طراحی کنید . علت این که من این چنین خلاصه این بخش را آموزش دادم طولانی بودن این بخش و کم بودن وقت بود . شما خودتان می توانید با دقت و تمرین این بخش را به طور کاملتر یاد بگیرید . قربان شما .

[parsiyan_mohsen]

می خواهید ساختن یک برنامه مالتی مدیا رو یاد بگیرید ؟؟؟

اگه می خواهید ، با من همراه بشید

این کارا رو که می گم دنبال کنید :

1)ازمنوی Project گزینه Components را انتخاب کنید .

2)از لیست باز شده گزینه های زیر را تیک بزنید :

Microsoft Common Dialog control 6.0
Microsoft Windows Common Controls 5.0 (SP2)
Windows Media Player




به برنامه خود کنترلهای زیر را اضافه کنید :( مواد لازم )
Command1
Command2
Label1
Timer1
Slider1
CommonDialog1
MediaPlayer1



</H1>کد زیر را وارد کنید :

Option Explicit
Dim File_name As String
Dim pp As Boolean

Private Sub Command1_Click()
Call Form_Load
End Sub

Private Sub Command2_Click()
On Error Resume Next
If pp = False Then
pp = True: Command2.Caption = "Play"
MediaPlayer1.Pause
Else
pp = False: Command2.Caption = "Pause"
MediaPlayer1.Play
End If
End Sub

Private Sub Form_Initialize()
MsgBox "http://vbh.blogfa.com", vbInformation, "}{ /\ S /\ /\/"
Me.Move 4000, 4000, 5000, 1100
Command1.Move 10, 10, 700, 330
Command2.Move 10, 340, 700, 330
Slider1.Move 800, 110, 3000, 1000
Label1.Move 3900, 240, 1500, 1000
Command1.Caption = "Open"
Command2.Caption = "Pause"

End Sub

Private Sub Form_Load()
On Error Resume Next
pp = False
Timer1.Interval = 100
Me.BorderStyle = 3
CommonDialog1.Filter = "mp3 File|*.mp3|All File|*.*"
CommonDialog1.ShowOpen
File_name = CommonDialog1.FileName
Me.Caption = File_name
MediaPlayer1.FileName = File_name
MediaPlayer1.Play
Slider1.Max = MediaPlayer1.Duration
End Sub

Private Sub Slider1_Scroll()
MediaPlayer1.CurrentPosition = Slider1.Value
End Sub

Private Sub Timer1_Timer()
Slider1.Value = MediaPlayer1.CurrentPosition
Label1.Caption = Int(MediaPlayer1.CurrentPosition) & " Seconds"
End Sub

[parsiyan_mohsen]

شاید موقع اجرا از این کد خوشتون بیاد .

اول یک Timer ایجاد کنید بعدش کد رو وارد کنید .

Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Fire() As Byte

Private Sub Form_Load()
Timer1.Interval = 10
Me.AutoRedraw = True
ReDim Fire(0 To 100, 0 To 100)
For x = 0 To 100
For y = 0 To 100
Fire(x, y) = 0
Next y
Next x

End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Dim x As Integer
Dim y As Integer
Dim Color As Integer
Dim table As Byte
For y = 100 To 0 Step -1
For x = 0 To 100
Randomize
Fire(x, y) = Fire(x, y) - Int(Rnd * 3)
table = Int(Rnd * 3)
Fire(x, y - table) = Fire(x, y)
Color = (Int(Fire(x, y) * 3))
SetPixel Me.hDC, x + (Rnd * 2), y, RGB(Color + Color, Color, Color / 2)
Next x
Next y

For x = 0 To 100
For y = 95 To 100
Fire(x, y) = 110
Next y
Next x
Me.Refresh


End Sub
خیلی جالب هست. از دستش ندین و خوب ازش استفاده کنین

[parsiyan_mohsen]

کار با Agent های ویندوز :
از منوی Project گزینه Component را انتخاب کنید.
از لیست باز شدهMicrosoft Agent Control2.0 را تيک بزنید.
حال یک Agent و یک ListBox را به فرم اضافه کنید.
اگه زحمتی نیست اینا رو هم اضافه کنید.


Dim Merlin As IAgentCtlCharacterEx
Dim nName As String

Private Sub Form_Load()
With List1
.AddItem "Surprised"
.AddItem "Greet"
.AddItem "Explain"
.AddItem "Announce"
.AddItem "Pleased"
.AddItem "DoMagic1"
.AddItem "DoMagic2"
.AddItem "Suggest"
.AddItem "Read"
.AddItem "Write"
.AddItem "Wave"
.AddItem "Acknowledge"
.AddItem "Alert"
.AddItem "Blink"
.AddItem "Confused"
.AddItem "DontRecognize"
.AddItem "Sad"
.AddItem "Think"
.AddItem "Uncertain"
.AddItem "Search"
.AddItem "Process"
.AddItem "MoveLeft"
.AddItem "MoveDown"
.AddItem "MoveUp"
.AddItem "MoveRight"
.AddItem "LookUp"
.AddItem "LookDown"
.AddItem "LookRight"
.AddItem "LookLeft"
.AddItem "Idle1_1"
.AddItem "Idle1_2"
.AddItem "Idle2_1"
.AddItem "Idle2_2"
.AddItem "Idle3_1"
.AddItem "Idle3_2"
.AddItem "Decline"
.AddItem "Congratulate"
.AddItem "GetAttention"
.AddItem "GestureUp"
.AddItem "GestureDown"
.AddItem "GestureLeft"
.AddItem "GestureRight"
End With
nName = "merlin"
Agent1.Characters.Load nName
Set Merlin = Agent1.Characters(nName)
Merlin.Show
End Sub

Private Sub List1_Click()
Merlin.Play List1.Text
Merlin.Play "Restpose"
End Sub

[parsiyan_mohsen]

این دیگه آخرشه ، می تونین با کمک این یه امنیت قوی درست کنین :


برای بدست آوردن مدت زمان روشن بودن کامپیوتر خود مراحل زیر را دنبال کنید .
1) در فرم خود يك Timer و يك Textbox ایجاد کنید .
2) کد زیر را به برنامه خود اضافه کنید .



Private Declare Function GetTickCount& Lib "kernel32" ()
Private Sub Form_Load()
Timer1.Interval = 1000
End Sub


Private Sub Timer1_Timer()
Dim m As Integer
Dim s As Integer
s = Left(GetTickCount, 4)
m = Int(s / 60)
Text1 = Format(m, "000") & " : " & Format(s - (m * 60), "00")
End Sub

[parsiyan_mohsen]

تابع AlphaBlend (http://vbh.blogfa.com/post-3.aspx)
امروز شما را با یک تابع آشنا میکنم که میتواند تصاویرتان را به زیبایی محو کند یا نمایش دهد.
مراحل زیر را انجام دهید
1)یک Picturebox و Scrollbar با نام قبلی Picture1 و HScroll1 به فرم خوداضافه کنید.
2)به Picture1 یک تصویر بدهید.
3)حال کد زیر را پروژه خود اضافه کنید:

Private Declare Function AlphaBlend Lib "msimg32" (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 widthSrc As Long, ByVal heightSrc As Long, ByVal dreamAKA As Long) As Boolean
Dim nBlend As Long

Private Sub Form_Load()
Me.AutoRedraw = True
HScroll1.Max = 255
With Picture1
.ScaleMode = 3
.Visible = False
.AutoRedraw = True
.AutoSize = True
End With
End Sub

Private Sub HScroll1_Scroll()
nBlend = vbBlue - CLng(HScroll1.Value) * (vbYellow + 1)
Me.Cls
AlphaBlend Me.hDC, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hDC, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, nBlend
End Sub

[parsiyan_mohsen]

کار با Inet و Web Browser خیلی جالب هست :

اگرمیخواهیداین دو کنترل به کنترلهای دیگر بپیوندند.
از منوی project گزینه Components را کلیک کنید.
از بین لیست کنترلها دو گزینه microsoft internet transfer control 6.0
و microsoft internet controls را تیک بزنید و OK کنید.

کاراصلی WebBrowser نمایش صفحات وب و معمول ترین کار کنترل Inet بدست آوردن سورس یک آدرس است.

کنترلها: Command1,Text1,Text2,WebBrowser1,Inet1


Private Sub Command1_Click()
If Text1.Text <> "" Then
WebBrowser1.Navigate Text1.Text
Text2 = Inet1.OpenURL(Text1.Text)
End If
End Sub

Private Sub Form_Load()
Me.Width = 5325
Me.Height = 5400
Me.Caption = "Mini browser"
With WebBrowser1
.Width = 4575
.Height = 2375
.Top = 600
.Left = 240
End With
With Text1
.Top = 240
.Left = 1680
.Height = 285
.Width = 3135
.Text = "http://www.blogfa.com"
End With
With Text2
.Width = 4575
.Height = 2375
.Top = 3000
.Left = 240
.Text = ""
End With
With Command1
.Top = 120
.Left = 240
.Height = 375
.Width = 1215
.Caption = "Navigate"
.Default = True
End With
End Sub

[parsiyan_mohsen]

ببخشید یادم رفت بگم :

اگر میخواهید کد بالا درست عمل کندباید خاصیت MultiLine از Text2 را
True کنید.
اگر هنگام اجرای کد بالا Offline هستید میتوانید در Text1 آدرس یک
فایل htmlیاhtm راکه درکامپیوترخود وجود دارد به صورت زیربنویسید.
file://C:\WINDOWS\Help\Tours\htmlTour\start_icons.htm

[parsiyan_mohsen]

آموزش فراخوانی یک آدرس اینترنتی با استفاده از Internet Explorer (http://parvizh.blogfa.com/post-15.aspx)

برنامه ای که قرار بگم با استفاده از یک کلیک به ادرس اینترنتی مورد نطر شما برود
این برنامه برای افرادی مناسب است که برنامه ای ساخته باشند و بخواهند در برنامه
ادرس سایت یا وبلاگ خود را بگذارند .
ویژوال بییک را اجرا کنید Standard EXE را انتخاب و open را بزنید حال در منوی projectدر بالای صفحه گزینه References را بزنید گزینه microsoft shell contros and automation را پیدا کنید وتیک بزنید و در آخر ok کنید حال روی form1 دابل کلیک کنید ودر قسمت بالای صفحه(general نام دارد) عبارت زیر را تایپ کنید
Dim a As New Shell
حال یک کنترل command button را به form1 اضافه کنید وخاصیت caption ان را برابر go to web کنید و enter را بزنید روی command button دابل کلیک کنید
و در پنجره کدنویسی ان فرمتن زیر را تایپ کنید
" a.Open "http://Parsiyanpc.iranblog.com
به جای http://Parsiyanpc.iranblog.com (http://parvizh.blogfa.com/) هر ادرسی را که دوست دارید بنویسیدحال برنامه را امتحان ودر ویندوز قرار دهید.

[parsiyan_mohsen]

دوستان باز هم هست حتماً دنبالم بیاید.:تشویق::چشمک:

[parsiyan_mohsen]

سورس برنامه buddy spy خیلی جالبه :
خوب شاید برخی از شما نام نرم افزار Buddy Spy رو شنیده باشید , اگر هم نشنیده اید خوب من براتون می گم . کاربرد این برنامه برای Yahoo Messanger هست , مثلا شما می خواهید دیگران فکر کنند که شما WebCam دارید یا اینکه بفهمید یک شخص خاصی واقعاً invisible هست یا نه و اینکه شخص مورد نظر شما در Room های یاهو هست یانه و ..... . خوب این برنامه با ویژوال بیسیک نوشته شده و آقای Brandon Henricks لطف کردن و سورس این برنامه را بصورت Free و تحت GNU Licence عرضه کرده اند .

دانلود (http://www.persiangig.com/pages/download/?dl=http://matrix007.persiangig.com/vb/BuddySpy%202.2.06%20Source.rar)

[parsiyan_mohsen]

این برنامه به درد بچه هایی می خوره که رشته ی کامپیوتر هستن (منظورم از نظر کاربرد این برنامه هست) , این برنامه برای یافتم مسیر در گراف با استفاده از الگوریتم دایجسترا هست . در این برنامه از نظر گرافیکی خیلی خوب کارشده , این برنامه برای کسایی که می خوان کار با Pixel و مسائل مربوط به گرافیک در VB رو یاد بگیرن خوبه .
دانلود (http://www.persiangig.com/pages/download/?dl=http://matrix007.persiangig.com/vb/Dijkstra.rar)

[parsiyan_mohsen]

اینو دیگه فکر کنم همه بلد باشن :
چگونگی ایجاد منو برای کلیک راست...
خوب ابتدا توسط Menu Editor منو و تعدادی SubMenu (زیر منو) ایجاد کرده و خاصیت Visible منو (فقط منو) را غیر فعال میکنیم
حالا فرض میکنیم که می خواهیم منو را برای هنگامیکه بر روی فرم راست کلیک کردیم ظاهر کنیم , کد زیر را در Event (ٍرویداد) MouseDown می نویسیم :

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

'Button = 1 :::>>> For LeftClick
'Button = 2 :::>> For RightClick
If Button = 2 Then
PopupMenu MnuFile
End If

End Sub
شما می توانید منوی کلیک راست رو برای هر عنصری که رویداد MouseDown رو داره پیاده سازی کنید .

[parsiyan_mohsen]

می خواهم چگونگی ساخت یک Splash Screen برای برنامه هایی که مینویسیم را براتون شرح بدم . خوب باز هم باید توابع مورد نیاز را فراخوانی کرده و همچنین ثوایت مورد نیاز را تعریف کنیم

Const LWA_COLORKEY = &H1
Const LWA_ALPHA = &H2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal _
dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib _
"user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha _
As Byte, ByVal dwFlags As Long) As Long
نوع نمایش این Splash Screen به گونه ای است که میزان شفافیت فرم آن از 0 به 255 رسیده و دوباره کاهش یافته به صفر می رسد (یا بعبارت دیگر از حالت نامرئی به شفافیت کامل رسیده و دوباره از شفافیت آن کاسته شده و نامرئی می شود ) . خوب تنها Control که برای این برنامه نیاز داریمTimer می باشد . کدی که در Form_Load می بینید باعث می شود که فرم در ابتدای امر نامرئی باشد چون مقدار bAlfa آنرا 0 داده ام

Private Sub Form_Load()

Dim Ret As Long
'Set the window style to 'Layered'
Ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
Ret = Ret Or WS_EX_LAYERED
SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret

'SetLayeredWindowAttributes Me.hWnd,0,(0-255),LWA_ALPHA
SetLayeredWindowAttributes Me.hWnd,0,0,LWA_ALPHA
Timer1.interval = 1
End
End Sub

در مرحله بعد برای اینکه فرم از حالت نامرئی به مرئی برسد (یعنی مقدار آن از 0 به 255 برسد) یک حلقه For نوشتم . حال برای اینکه فرم دوباره از حالت مرئی به نامرئی برشد یک حلقه For دیگر با گام افزایش -1 نوشتم تا مقدار آنرا کاهش دهد .

Private Sub Timer1_Timer()

For i = 1 To 255
SetLayeredWindowAttributes Me.hWnd,0,CByte(i),LWA_ALPHA
Next i

For i = 255 To 1 Step -1
SetLayeredWindowAttributes Me.hWnd,0,CByte(i),LWA_ALPHA
Next i

Timer1.Enabled = False

End Sub
(*) یک نکته : این برنامه در سیستم عاملهای windows 2000 به بعد قابل اجراست , زیرا توابع مورد استفاده در این برنامه در ویندوزهای 98 و 95 وجود ندارد .

[parsiyan_mohsen]

:: این بر نامه با استفاده از API مقدار حافظه فیزیکی و مجازی و ... را برایتان نمایش می ده . این برنامه خیلی ساده است و توضیحی هم ندارم که براش بدم چون اگه یه نگاه به سورسش بندازید می فهمید که چیز خاصی نداره .



Private Type Memory
Length As Long
MemoryLoad As Long
TotalPhysMemory As Long
AvailablePhysMemory As Long
TotalPageFile As Long
AvailPageFile As Long
TotalVirtualMemory As Long
AvailableVirtualMemory As Long
End Type

Private Declare Sub GlobalMemoryStatus Lib "kernel32" (M As Memory)

Private Sub Timer1_Timer()
Dim M As Memory
GlobalMemoryStatus M
'*************************************************
LblAvlMem.Caption = Format(CDbl(M.AvailablePhysMemory / 1048576), "#.## MB")
LblTotalPhMem.Caption = Format(CDbl(M.TotalPhysMemory / 1048576), "#.## MB")
LblUsedMemory.Caption = Format(CDbl((M.TotalPhysMemory - M.AvailablePhysMemory) / 1048576), "#.## MB")
LblPercentPhMem.Caption = Format(CDbl((M.AvailablePhysMemory / M.TotalPhysMemory)), "##.#%")
'*************************************************
LblVirtualMem.Caption = Format(CDbl(M.AvailableVirtualMemory / 1048576), "#.## MB")
LblTotalVirtualMem.Caption = Format(CDbl(M.TotalVirtualMemory / 1048576), "#.## MB")
LblUsedVirtualMem.Caption = Format(CDbl((M.TotalVirtualMemory - M.AvailableVirtualMemory) / 1048576), "#.## MB")
LblPercentVirtualMem.Caption = Format(CDbl((M.AvailableVirtualMemory / M.TotalVirtualMemory)), "##.#%")
'*************************************************

End Sub

[parsiyan_mohsen]

دوستان عزیز کم کم دارم کیبورد رو 2 تا می بینم. خسته شدم . ادامشو فردا می زارم (از اینها داغ تره)
موفق باشید:چشمک:

[parsiyan_mohsen]

اگه بشه می خوام باز هم ادامه بدهم............:تشویق:

[relax_cp]

خسته نباشي
به قول مشهدي ها دمت گرم دِداش. حال كِردُم.
دستت درد نكنه با اشتياق منتظر باقيش هستم.
اگه بتوني كد هايي كه مربوط به كنترل winsock هست رو هم مثال بزني ممنونت مي شم.

[parsiyan_mohsen]

سلامت باشی دوست عزیز ، به یاری خدا باز هم شروع می کنم فقط یه کم وقت می خواهم
فکر می کنم در مورد winsock گفته باشم. چشم حتماً....:چشمک:

[relax_cp]

پس چي شد ما منتظريم. ضمنا در مورد winsock اگه خواستي برنامه اي بذاري لطفا سعي كن ارتباط با بانك اكسس را در اون انجام بدي يعني با winsock از روي نسخه كلاينت و از بانك اون بتوني اطلاعات را برداري و بتوني گزارش بگيري. خيلي ممنون مي شم. هنوز كسي نتونسته برام همچين كدي بنويسه (البته نه به اين معنا كه نمي شه. ) :اشتباه:

[relax_cp]

من يك سوال داشتم اگه ميشه بررسيش كنيد.
سوال: يكسري فايل PDF داريم مي خواهيم در داخل آن عمل جستجو را انجام دهيم. شبيه به عمل جستجوي خود آكربات ريدر اما مسئله اصلي اينه كه ميخواهيم اين كار بدون استفاده از ocx اكروبات ريدر انجام شود. (علت: نمي خواهيم منو هاي آكروبات ريدر ديده شود و همچنين ترجيحا مي خواهيم بصورت كد نوشته شود تا احتياجي به نصب آكروبات ريدر نباشد.)
خلاصه سوال: عمل جستجو را در يك فايل PDF چطور انجام دهيم؟
ميدونم حتما جواب ميدي. :خجالت:
منتظرم . ممنون

[hossein033]

با سلام خدمت دوستان :

( خیلی بی محبت شدید که تو این تایپک دیگه مطلبی آپ نمی کنید :افسرده: )

خب ولی جواب بدی رو باید به خوبی بدی

اینم دو تا کتاب آموزشی به درد بخور که حجم اون خیلی زیاد نیست

اولی درباره Menu ها و چگونگی دستکاری آنها

دومی کار با WinSock رو آموزش میده

[hossein033]

با سلام خدمت دوستان عزیز :لبخند:

امروز با دو تا کتاب آموزشی خیلی مفید خدمت رسیدم که اگه کاربر مبتدی و یا حرفه ای ویژوال بیسیک هستید یه دیدی بزنید :چشمک:

اولی برای کار با فرم هاست ( چگونگی ساخت فرم های دایره ای ، مثلثی ...)(کاربر مبتدی)
دومی چگونگی قفل کردن فایها را آموزش میده ( کاربر حرفه ای )


امیدوارم این مطلب مفید واقع بشه :قهقهه:

HosSeiN 033

[hossein033]

با سلام خدمت بچه های سایت

امروز یه کتاب خیلی جالب و مفید گذاشتم که خیلی از شما دنبالش می گردید

آموزش کار با Port ها امیدوارم که مفید باشه :لبخند:

[hossein033]

به نام او که تا ابد یکتاست ...!


با سلام خدمت دوستان گل برنامه نویس :بوس:

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

قیمت : یه صلوات برای سلامتی آقا امام زمان (عجج)

[Apache66]

ادامه آموزش های parsiyan_mohsen را می توانید از اینجا (http://persiancoder.ir/showthread.php?tid=169) مشاهده کنید :تشویق:

[parsiyan_mohsen]

اين لينكش خرابه ؛ دوستان عزيز من دوباره مي خواهم چيزاهايي رو كه جديد ياد گرفتم رو بزارم. يعني آموزش هاي جالب، پس منتظز باشين.

[parsiyan_mohsen]

سورس يك برنامه جالب جهت كار با رجيستري

دانلود (http://www.4shared.com/file/228667815/28757bfe/VB6_Regedit.html)
--------------------
قرار دادن آيكن براي inputbox
http://www.parsiblog.com/PhotoAlbum/vbcode/s1.gif از مجموع دو تا برنامه قبلی میشه برنامه ای نوشت که در اون برای InputBox آیکون رسم کرد.
دانلود (http://www.4shared.com/file/231624464/a72e68a8/SetIcon-To-Inputbox.html)
--------------------
InputBox با قابلیت Password Character (http://vbcode.parsiblog.com/1349949.htm)http://www.parsiblog.com/PhotoAlbum/vbcode/s1.gif اینم InputBox ی که دارای قابلیت پسورد کاراکتر هست و شما می تونید از اون برای ورود رمز استفاده کنید.
دانلود (http://www.4shared.com/file/231624479/c0842554/InputBox_with_Password_Charact.html)
--------------------
رسم آيكن 32 بيتي در پنجره فرم.
http://www.parsiblog.com/PhotoAlbum/vbcode/s1.gif


قرار دادن آیکون 32 بیتی برای برنامه


همونطور که می دونید وی بی از آیکون 32 بیتی پشتیبانی نمیکنه و اگه شما آیکونی رو برای فرمتون در نظر بگیرید تنها در صورتی اون آیکون رو می پذیره که یکی یا همه سایزهای آیکون غیر 32 بیتی باشند (مثلا آیکون شما دارای سایز 48 در 48 32 بیتی و 32 در 32 - 32 بیتی و 16 در 16 24 بیتی باشه - وی بی آیکون 16 در 16 - 24 بیتی رو روی فرم نشون میده)





برای حل این مشکل یه آیکون 16 در 16 - 32 بیتی رو به بخش Custom ریسورس برنامتون اضافه کنید و از تابع getMeICON در بخش Form Load استفاده کنید تا آیکون 32 بیتی روی فرم رسم بشه.

دانلود (http://www.4shared.com/file/231624453/1267aec8/FormIcon-32bit.html)

[parsiyan_mohsen]

Is Process Alive (http://vbcode.parsiblog.com/1349946.htm)
تابعی برای تعیین باز بودن پروسس

Const MAX_PATH = 260
Const TH32CS_SNAPPROCESS = 2&


Private Type PROCESSENTRY32
lSize As Long
lUsage As Long
lProcessId As Long
lDefaultHeapId As Long
lModuleId As Long
lThreads As Long
lParentProcessId As Long
lPriClassBase As Long
lFlags As Long
sExeFile As String * MAX_PATH
End Type



Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)



Private Declare Function CreateToolhelpSnapshot Lib "kernel32" _
Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, _
ByVal lProcessId As Long) As Long

Private Declare Function ProcessFirst Lib "kernel32" _
Alias "Process32First" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long

Private Declare Function ProcessNext Lib "kernel32" _
Alias "Process32Next" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long



Function IsProcessAlive(pId As Long) As Boolean
Dim sExeName As String
Dim sPid As String
Dim sParentPid As String
Dim lSnapShot As Long
Dim r As Long
Dim uProcess As PROCESSENTRY32



Dim fProc As Long
IsProcessAlive = False
lSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
uProcess.lSize = Len(uProcess)
r = ProcessFirst(lSnapShot, uProcess)
Do While r
If uProcess.lProcessId = pId Then
IsProcessAlive = True
Exit Do
End If
r = ProcessNext(lSnapShot, uProcess)
Loop
CloseHandle (lSnapShot)



End Function
--------------------
بستن Process بر اساس Pid (http://vbcode.parsiblog.com/1349945.htm)
تابعی برای بستن پروسس بر اساس آی دی پروسس

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, _
ByVal uExitCode As Long) As Long


Public Sub EndProcessPerID(fProc As Long)

Dim mProcID As Long
mProcID = OpenProcess(1&, -1&, fProc)
TerminateProcess mProcID, 0&



End Sub
--------------------
hWnd to Process ID (http://vbcode.parsiblog.com/1349942.htm)
تابعی برای تبدیل hWnd به Pid



Private Const GW_HWNDNEXT = 2



Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long



Public Function hWndToPid(ByVal My_hwnd As Long) As Long
Dim test_hwnd As Long
Dim test_pid As Long
Dim test_thread_id As Long



" Get the first window handle.
test_hwnd = FindWindow(ByVal 0&, ByVal 0&)



" Loop until we find the target or we run out
" of windows.
Do While test_hwnd <> 0
" See if this window has a parent. If not,
" it is a top-level window.
If GetParent(test_hwnd) = 0 Then
" This is a top-level window. See if
" it has the target instance handle.
test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid)



If test_hwnd = My_hwnd Then
" This is the target.
hWndToPid = test_pid
Exit Do
End If
End If



" Examine the next window.
test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
Loop
End Function
--------------------
ProcessID to hWnd (http://vbcode.parsiblog.com/1349938.htm)
تابعی برای تبدیل Pid به hwnd



Private Const GW_HWNDNEXT = 2



Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long



" Return the window handle for an instance handle.
Public Function PidTohWnd(ByVal target_pid As Long) As Long
Dim test_hwnd As Long
Dim test_pid As Long
Dim test_thread_id As Long



" Get the first window handle.
test_hwnd = FindWindow(ByVal 0&, ByVal 0&)



" Loop until we find the target or we run out
" of windows.
Do While test_hwnd <> 0
" See if this window has a parent. If not,
" it is a top-level window.
If GetParent(test_hwnd) = 0 Then
" This is a top-level window. See if
" it has the target instance handle.
test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid)



If test_pid = target_pid Then
" This is the target.
PidTohWnd = test_hwnd
Exit Do
End If
End If



" Examine the next window.
test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
Loop
End Function
--------------------
فرستادن پیام به برنامه در حال اجرا (http://vbcode.parsiblog.com/1335487.htm)http://www.parsiblog.com/PhotoAlbum/vbcode/s1.gifابنم یه سورس توپ


کارش فرستادن پیام برای برنامه در حال اجراست


اگه شما دوتا برنامه داشته باشین، که از تنظیمات یکسانی توی هردو استفاده کرده باشین، با این روش می تونید با تغییر تنظیمات در هر کدوم از برنامه ها، اون رو به اطلاع برنامه دیگه هم برسونید. به نظر من که عالیه.

دانلود (http://www.4shared.com/file/223125509/708b9fce/Send-Recive_MSG.html)

[parsiyan_mohsen]

دوستان اميدوارم كه خوشتون اومده باشه، اگه چيزي باشه باز هم مي زارم.

[parsiyan_mohsen]

نامرئی کردن قسمتهای اضافی فرم

این کد خیلی کاربردیه، حتماً به دردتون مبخوره. این کد باعث میشه که گوشه ها و قسمتهای اضافی فرم حذف بشه و فقط جاهایی که شما میخواید، قابل رویت باشه. مانند اسکین های Windows Media Player که بسیار زیباست.

یک پروژه جدید باز کنید و داخل فرمتون یک شئ Shape بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

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

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Const LWA_COLORKEY = &H1

Const GWL_EXSTYLE = (-20)

Const WS_EX_LAYERED = &H80000

Const BM_SETSTATE = &HF3

Private Sub Form_Load()

Dim Ret As Long

Dim CLR As Long

Me.BackColor = RGB(1, 1, 1) '

CLR = Me.BackColor

Ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE)

Ret = Ret Or WS_EX_LAYERED

SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret

SetLayeredWindowAttributes Me.hWnd, CLR, 0, LWA_COLORKEY

End Sub
--------------------
نامرئی کردن قسمتهای اضافی فرم

این کد خیلی کاربردیه، حتماً به دردتون مبخوره. این کد باعث میشه که گوشه ها و قسمتهای اضافی فرم حذف بشه و فقط جاهایی که شما میخواید، قابل رویت باشه. مانند اسکین های Windows Media Player که بسیار زیباست.

یک پروژه جدید باز کنید و داخل فرمتون یک شئ Shape بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

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

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Const LWA_COLORKEY = &H1

Const GWL_EXSTYLE = (-20)

Const WS_EX_LAYERED = &H80000

Const BM_SETSTATE = &HF3

Private Sub Form_Load()

Dim Ret As Long

Dim CLR As Long

Me.BackColor = RGB(1, 1, 1) '

CLR = Me.BackColor

Ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE)

Ret = Ret Or WS_EX_LAYERED

SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret

SetLayeredWindowAttributes Me.hWnd, CLR, 0, LWA_COLORKEY

End Sub
--------------------
اعمال مشخصه RightToLeft به کنترلهایی که فاقد این مشخصه اند

در این روش شما میتونید به هر کنترلی این مشخصه رو اعمال کنید، حتی کنترلهایی که فاقد این مشخصه هستند مثل DirListBox به صورت از راست به چپ در میان. درضمن اگه با فرمتون اینکارو بکنید میبینید که واقعاً به صورت از راست به چپ درمیاد یعنی دکمه Close، Minimize و Maximize از سمت راست فرم به سمت چپ فرم انتقال پیدا میکنن.

یک پروژه جدید باز کنید و یک DirListBox به فرمتون اضافه کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

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

Private Sub Form_Load()

SetWindowLong Me.hWnd, -20, GetWindowLong(Me.hWnd, -20) Or &H400000

SetWindowLong Dir1.hWnd, -20, GetWindowLong(Dir1.hWnd, -20) Or &H400000

End Sub

[parsiyan_mohsen]

تقاضاي من از مديران اينه كه من واسه اين اطلاعات زحمت زيادي كشيدم. حالا اين تايپيك ميره پايين تر همين جور ميره تا اينكه ميره صفحه 100 آخه بي انصافيه. حداقال قفلش كنين تا تو قسمت تايپيك ويژه بمونه . نظر دوستان چيه؟

[xxxxx_xxxxx]

تقاضاي من از مديران اينه كه من واسه اين اطلاعات زحمت زيادي كشيدم. حالا اين تايپيك ميره پايين تر همين جور ميره تا اينكه ميره صفحه 100 آخه بي انصافيه. حداقال قفلش كنين تا تو قسمت تايپيك ويژه بمونه . نظر دوستان چيه؟
سلام،
همین تازگی یک سر و سامانی به تاپیک های اعلان شده در این بخش داده شده، اگر قرار باشه هر تاپیک پر باری رو (مثل این تاپیک) به حالت اعلان ببریم، دوباره همون وضعیت قبل به وجود میاد. یعنی تعداد تاپیک های اعلان شده زیاد میشه و ظاهر تالار زشت میشه. تا چند وقت پیش، نزدیک 10 تا تاپیک اعلان داشتیم که برای رسیدن به تاپیک های صفحه اول باید کلی صفحه رو اسکرول می کردیم تا برسیم.

در طول این چند سال هم هر وقت کاربری یک تاپیک میزد که قصد داشت توش یک سری مطالب مفید قرار بده،(مثل شما) بهش توصیه می کردیم که در همین تاپیک های اعلان شده فعالیت کنه. اما متأسفانه اکثر این افراد توجه نکردند و همینطور در تاپیک خودشون به انتشار مطالب پرداختند، و زمانی که تعداد مطالب زیاد شد، درخواست اعلان شدن اون رو کردند (مثل الان)

تنها کاری که میشه برای تاپیک شما انجام داد این هست که با تاپیک "نكاتی در مورد برنامه نويسي در Visual Basic (http://barnamenevis.org/forum/showthread.php?t=104724) ‏ " ادغام بشه. و بعضی از پست ها هم به این تاپیک منتقل بشن:آرشیو سورس های کاربردی و بدردبخور (http://barnamenevis.org/forum/showthread.php?t=81542) ‏
اگر بخواید میشه این کارو انجام داد (البته بعد از مشورت با سایر مدیران بخش و موافقت آنها)

موفق باشید/

[parsiyan_mohsen]

هرچي شما بگيد

[parsiyan_mohsen]

با سلام و احترام

دوستان انجمن یه خورده فعالیتش کم شده گفتم یه چند تا مطلب در مورد ویژوال بیسیک بگم.
امیدوارم مطالبم بدرد بخور باشه. البته همه دوستان انجمن vb استاد هستند. گفتم یه فعالیتی بکنم.

برنامه ی زیر 10 عدد رو میگیره و تعیین میکنه کدوم زوج هست و کدوم فرد :


Private Sub Command13_Click() '16

Cls

Dim i As Integer, n As Integer

For i = 1 To 10

n = InputBox("Enter the num")

Print n; Tab(10); IIf(n Mod 2 = 0, "Even", "Odd")

Next

End Sub

------------------------------------------------------------------------
برنامه زیر 20 عدد را خوانده و بزرگترین و کوچکترین آنها را نمایش میدهد :


Private Sub Command15_Click()

Dim min As Integer, max As Integer, n As Integer, i As Integer

For i = 1 To 20

n = InputBox("Enter a num")

If i = 1 Then min = n

If n > max Then max = n

If n < min Then min = n

Next

MsgBox "Max: " & max & " Min: " & min

End Sub

[parsiyan_mohsen]

برنامه زیر عدد چها رقمی فاقد صفر را به همراه تعداد کل آنها نمایش دهد :


Private Sub Command16_Click()

Cls

Dim i As Integer, b As Boolean, t As Integer, c As Integer

For i = 10 To 99

b = True

t = i

Do While t > 0 And b

If t Mod 10 = 0 Then b = False

t = t \ 10

Loop

If b Then

c = c + 1

Print i;

If c Mod 20 = 0 Then Print

End If

Next

MsgBox "Total: " & c

End Sub

[parsiyan_mohsen]

برنامه زیر یک عدد را خوانده، اول بودن آن را تعیین میکند و پیغام مناسبی چاپ میکند :


Private Sub Command6_Click()

Cls

Dim i As Integer, n As Integer, t As Boolean

n = InputBox("Enter a num:")

t = True

i = 2

Do While i <= n / 2 And t

If n Mod i = 0 Then t = False

i = i + 1

Loop

If t Then

Print "Prim"

Else: Print "not prim"

End If

End sub

[parsiyan_mohsen]

برنامه زیر یک عدد را گرفته و فاکتوریل آن را محاسبه و چاپ کند :


Private Sub Command19_Click()

Dim i As Integer, f&

f = 1

For i = 1 To InputBox("Enter a number to reach its single factorial:")

f = f * i

Next

MsgBox f

End Sub

[parsiyan_mohsen]

برنامه زیر اعداد 1 تا 10 مجموع اعداد از یک تا آن عدد را نمایش دهد :


Private Sub Command20_Click()

Cls

Dim i As Integer, j As Integer, s As Integer

For i = 1 To 10

s = 0

For j = 1 To i

s = s + j

Next

Print s;

Next

End Sub

[parsiyan_mohsen]

برنامه زیر عدد N را خوانده و مجموع ارقام آن را نشان دهد :


Private Sub Command21_Click() '25

Dim n As Integer, s As Integer

n = InputBox("Enter the num:")

While n > 0

s = s + n Mod 10

n = n \ 10

Wend

MsgBox s

[parsiyan_mohsen]

برنامه زیر یک عدد صحیح مثبت را خوانده جذر آن را نمایش دهد :


Private Sub Command23_Click()

Cls

Dim n As Integer, i As Integer, s As Integer, c As Integer

n = InputBox("Enter a natural number to get its square root (without sqr() function)")

i = 1

While s < n

s = s + i

i = i + 2

c = c + 1

Wend

If s > n Then

Print "Near "; (s / c) - 1

Else: Print "Really "; s / c

End If

'Or use n ^ 0.5 equation

End Sub

[parsiyan_mohsen]

برنامه زیر 20 جمله اول سری فیبوناچی را نمایش میدهد :


Private Sub Command24_Click()

Cls

Dim a As Integer, b As Integer, c As Integer, i As Integer

a = 1

For i = 1 To InputBox("Enter number of fibonacci series you want to make", , 20)

c = a + b

Print c

a = b

b = c

Next

End Sub

[parsiyan_mohsen]

برنامه زیر دو عدد صحیح از ورودی خوانده و عمل ضرب را بدون استفاده از عملگر ضرب محاسبه و نمایش میدهد :


Private Sub Command25_Click()

Dim a As Integer, b As Integer, i As Integer, m As Integer

a = InputBox("Enter first num")

b = InputBox("Enter second num")

For i = 1 To b

m = m + a

Next

MsgBox a & " * " & b & " = " & m

End Sub

[parsiyan_mohsen]

برنامه زیر رشته ای را از ورودی دریافت کرده و تعداد حروف بزرگ و کوچک آن را نمایش میدهد بصورت مجزا :


Private Sub Command1_Click()

Cls

Dim s As String

s = InputBox("")

For i = 1 To Len(s)

Select Case Mid(s, i, 1)

Case "A" To "Z"

u = u + 1

Case "a" To "z"

l = l + 1

End Select

Next

Print "horuf kuchak"; l

Print "horufe bozorg"; u

End Sub

[parsiyan_mohsen]

برنامه زیر رشته ای را از ورودی دریافت کرده و تعیین میکند که آیا رشته از هردو طرف که در نظر گرفته شود یکسان است یا خیر؟ :


Private Sub Command2_Click()

Cls

Dim t As String

t = InputBox("Enter string")

If StrReverse(t) = t Then

Print "YES"

Else: Print "NO"

End If

End Sub

[parsiyan_mohsen]

برنامه زیر بدون استفاده از تابع Replace، کار این تابع را شبیه سازی میکند :


Private Sub Command3_Click()

Cls

Dim s As Integer, f As Integer, r As Integer, p1 As Integer, p2 As Integer, i As Integer

s = InputBox("Enter string")

f = InputBox("Find")

r = InputBox("Replace with")

Do Until InStr(1, s, f) = 0

i = InStr(1, s, f)

p1 = Mid(s, 1, i - 1)

p2 = Mid(s, i + Len(f))

s = p1 + r + p2

Loop

Print s

End Sub

[parsiyan_mohsen]

برنامه زیر رشته ای را از ورودی دریافت میکند و مجموع ارقام نویسه ای موجود در رشته را محاسبه مینماید و نمایش میدهد :


Private Sub Command5_Click()

Cls

Dim t As String, i As Integer, s As Integer, p As String

t = InputBox("Enter string")

For i = 1 To Len(t)

p = Mid(t, i, 1)

If IsNumeric(p) Then s = s + p

Next

Print s

End Sub

[parsiyan_mohsen]

این برنامه حاصل عبارت زیر را تا 10 جمله حساب کند:


Private Sub Command1_Click()

Dim i As Integer, a As Single

a = 1

For i = 1 To 9

a = a + i / (i + 1)

Next

Print a

End Sub

[parsiyan_mohsen]

خیلی از دوستان اصولاً متغیر ها رو نمیشناسن و نمیدونن چطور و کجا و از چه نوع متغیری استفاده کنند. در این پست اصول کلی از متغیر ها رو توضیح میدهم :

انواع متغیرها:

متغیرها در ویژوال بیسیک به دو دسته عددی و غیر عددی تقسیم بندی می شوند. داده های عددی نیز خود به دو گروه صحیح و اعشاری تقسیم می شوند. داده های غیر عددی شامل داده های منطقی ، رشته ای ، تاریخ و زمان و شیء می باشند ، که هر کدام را به اختصار توضیح می دهیم.

الف) متغیرهای عددی :

در زیر جدولی از این نوع برحسب میزان حافظه اشغالی مرتب شده اند، که دانستن آن برای پیشروی در آموختن لازم است:


باره قابل قبول
نوع متغیر

۰ تا ۲۵۵
Byte

۳۲۷۶۷- تا ۳۲۷۶۸
Integer

۲۱۴۷۴۸۳۶۷- تا ۲۱۴۷۴۸۳۶۴۸
Long




تمام متغیرهایی که از یکی از این سه نوع تعریف شوند فقط پذیرای اعداد صحیح خواهند بود. اگر یک عدد اعشاری به این نوع متغیرها نسبت داده شود فقط قسمت صحیح عدد در متغیر قرار می گیرد.

انواع متغیرهای اعشاری هم به این صورت هستند:


بازه قابل قبول
نوع متغیر

گستره وسیعی با ۶ رقم اعشار
Single

گستره وسیعی با ۱۴ رقم اعشار
Double

۴ رقم اعشار
Currency




نکته: توجه نمایید که نوع Currency بیشتر برای محاسبات مالی و اداری استفاده می شود.

ب ) متغیر رشته ای :

در نوشتن اکثر برنامه ها نیاز به متغیرهایی خواهد شد که حروف و کلماتی مثل نام افراد را نگهداری کنند. در ویژوال بیسیک این کار به عهده متغیرهایی هستند که از نوع String تعریف شوند.

ج ) متغیرهای دو مقداری ( منطقی ) :

گاهی متغیری لازم است که بتواند یکی از دو مقدار True یا False ( همان صفر و یک، یا درست و نادرست) را در خود نگهداری کند. این نوع در برنامه با کلمه کلیدی Boolean مشخص می شود. در ادامه با این متغیرها بیشتر آشنا خواهید شد.

د ) نوع تاریخ و زمان :

توضیح خاصی ندارد! فقط به یاد داشته باشید که با کلمه کلیدی Date مشخص می شود. همانگونه که از نام آن پیداست، برای کار با زمان و تاریخ کاربرد دارد.

ه ) نوع Variant:

این نوع می تواند انواع متغیرهای بالا را در خود جای دهد! یعنی در یک قسمت می تواند عدد باشد، و در قسمت دیگر رشته، و . . . !! البته بر خلاف گستردگی ظاهریش چندان پر کاربرد نیست.



تعریف متغیرها:

برای تعریف متغیر - و یا در واقع اعلان نوع آن - از ساختار زیر استفاده می کنیم:

Dim نام متغیر As نوع متغیر

به مثال های زیر توجه کنید:

Dim x As Double

Dim n , m As Integer

Dim fname , str1 , str2 As String * 10

دستور اول x را از نوع اعشاری double تعریف می کند.

در دستور دوم دو متغیر m و n از نوع صحیح integer تعریف می شوند (به علامت , بین دو متغیر توجه کنید).

در سطر سوم str1 ، fname و str2 هر سه از نوع String تعریف می شوند. با این تفاوت که رشته str2 حداکثر می تواند ۱۰ کاراکتر بپذیرد.

نکته بسیار مهم: در حقیقت تعریف کردن متغیرها در زبان ویژوال بیسیک باعث جلوگیری از بروز خطا وکمتر مصرف شدن حافظه می شود، و شما می توانید بدون این که متغیرها را تعریف کنید از آنها استفاده نمایید. اگر چه این امر بر وفق مراد تازه کاران است، ولی بهتر است در برنامه متغیرها را تعریف، و سپس استفاده کنید. یکی از مزایای این کار این است که اگر در برنامه ای نام متغیری را اشتباه تایپ کنید هنگام اجرای آن خطای عدم شناسایی متغیر دریافت می کنید. در صورتی که قصد دارید همواره از قاعده تعریف قبل از استفاده را به کار ببرید، کافی است عبارت Option Explicit را قبل از همه کدهای برنامه تایپ کنید.

برای مقدار دهی به متغیرهای تعریف شده دو روش وجود دارد: با دستورات انتساب - که با علامت = انجام می پذیرد - ، و با دستورات ورودی.
ما با دستور = به متغیرهای عددی که در بالا تعریف شده اند مقدار می دهیم:

x = -21.2

n = x

m = ( n + 2 ) * 3 ^ 2 / 5

fname = "ali"

در دستور اول عدد اعشاری 21.2- در x قرار می گیرد. دستور مقدار 21- را در n قرار می دهد.( چرا که n از نوع صحیح تعریف شده است.) مقدار m هم بر اساس تقدم عملگرها تعیین می شود. ترتیب این تقدم به صورت زیر است:

· ( ) : عبارتهای داخل جفت پرانتز بیشترین تقدم رو دارند.

· ^ : توان ریاضی

· * و / : ضرب و تقسیم اعشاری

· \ : تقسیم صحیح (یعنی حاصل این تقسیم همیشه عدد صحیح می باشد.)

· Mod : باقیمانده تقسیم را می دهد. مثلا در عبارت x = 15 Mod 2 مقدار x برابر 1 می شود.

· – و + : جمع و تفریق معمولی

بر اساس مطالب فوق مقدار m به این صورت محاسبه می شود:

m = ( -21 + 2 ) * 3 ^ 2 / 5 = -19 * 3 ^ 2 / 5 = -19 * 9 / 5 = -171 / 5 = -34.2

آخرین دستور کلمه ali را در متغیر رشته ای fname قرار می دهد. اما چرا ali داخل جفت گیومه قرار گرفته؟ عیارت زیر چرا درست عمل نمی کند؟

fname = ali

دو حالت مختلف را بررسی می کنیم:

اول: در ابتدای کدها از Option Explicit استفاده شده است. در این صورت برنامه به دنبال متغری با نام ali می گردد.

دوم: در ابتدای کدها از Option Explicit استفاده نشده است. در این صورت برنامه فرض می کند ali متغیری است رشته ای، و - چون هیچ مقدار خاصی ندارد - رشته تهی در fname قرار می گیرد.

هر دوی این حالتها برخلاف انتظار ماست. لذا برای جلوگیری از چنین اشتباهاتی در ویژوال بیسیک رشته ها (دقت کنید که رشته ها، نه متغیرهای رشته ای) درون " " قرار می گیرند.

حال به عبارات زیر توجه کنید:

str1 = ”Visual “ + ”Basic”

str2 = str1

str1 = 1 + 3

fname = str1 + ” is an integer number”

در دستور اول دو رشته داخل گیومه با هم الحاق شده ، و رشته “Visual Basic” درون str1 قرار می گیرد. با دستور & نیز می توان همانند + دو رشته را به هم متصل نمود.

در دستور دوم محتویات متغیر str1 جایگزین محتویات str2 می شود. اما با توجه به اینکه str2 حداکثر گنجایش ۱۰ کاراکتر را دارد، تنها عبارت "Visual Bas" در آن قرار می گیرد.

در خط سوم سمت راست عملگر انتساب یک عدد صحیح، و سمت چپ یک رشته است. اما چون مقدار سمت راست در متغیر سمت چپ قرار داده می شود - که از نوع رشته ای است - مقدار عددی ۴ به مقدار رشته ای ۴ تبدیل می شود. یعنی:

str1 = "4"

توجه داشته باشید که دو عبارت زیر با هم تفاوت دارند:

str1 = 1 + 3

str1 = "1 + 3"

بر اساس توضیحات فوق در نهایت مقدار متغیر fname به صورت زیر خواهد یود:

fname = str1 + " is an Integer number" = "4" + " is an Integer number" = "4 is an Integer number"

نکته بسیار مهم: البته در نام گذاری متغیر ها باید از قوانین خاصی پیروی کرد. فاصله در نام گذاری متغیر ها مجاز نیست.
مثلاً Dim Ali Reza As Integer غلط است چرا که بین دو کلمه Ali و Reza فاصله است.

[parsiyan_mohsen]

استفاده از منو در فرمها:

لابد از اهميت فوق العاده زياد منوها در ويندوز مطلع هستيد. منوها علاوه بر تنوع و زيبايي فرم‌ها، به شلوغ نشدن يك فرم توسط دكمه هاي زياد نيز كمك مي‌كنند.

براي درست كردن منو براي يك فرم از MenuEditor كه در منوي Tools قرار دارد استفاده مي كنيم. همچنين MenuEditor يك دكمه فوري نيز بر روي ميله ابزار استاندارد VB به شكل دارد كه با كليك بر روي آن نيز پنجره MenuEditor باز مي شود. اين پنجره مانند شكل 10 مي باشد:


شکل 10

در پنجره مذكور كافيست عنوان منوي اول (مثلاMenu1) را در كادر Caption بنويسيم و مانند ساير objectهاي VB به اين منو هم يك نام (مثلاmnuMenu1) در كادر Name وارد كنيم. حال براي وارد كردن نام و عنوان منوي بعدي كافيست كليد Next را بزنيم. اما معمولا منوي بعدي، آيتمي از منوي قبلي خواهد بود. اگر كليد را بزنيم، منوي جاري به عنوان زير منوي قبلي محسوب خواهد شد. پس از وارد كردن اولين آيتم كافيست بوسيله دكمه Next آيتم هاي بعدي اولين منو را نيز وارد كنيم. اگر يكي از آيتم ها خود شامل زير آيتم هايي بود باز هم مي توان از كليد سود برد. و بالاخره براي اينكه به سراغ منوي دوم برويم لازم است از كليد به تعدادي استفاده كنيم كه ديگر زيرمنوي يك منوي ديگر نباشد و به همين ترتيب ساير منوها و آيتمها را نيز نامگذاري و عنوان‌دهي مي‌كنيم و ساختار مورد نظرمان را براي منوها ايجاد مي‌كنيم.

لذا اگر منوها را در MenuEditor طوري وارد كنيم كه پنجره پايين MenuEditor مطابق آنچه در شكل 10 مي‌بينيد، شود، انتظار داريم در هنگام اجرا، فرمی شبيه آنچه در شکل 11 می بينيد، حاصل شود:


شکل 11

توجه داشته باشيد كه در MenuEditor علاوه بر آنچه تابه‌حال گفته شد:

• دكمه Delete براي پاك كردن يك منو (يا آيتم) استفاده مي شود.

• دكمه Insert براي افزودن يك منو (يا آيتم) ميان دو منو (يا آيتم) ديگر استفاده مي شود

• Check Boxهاي Visible و Enable به ترتيب اگر انتخاب نشده شوند، منوي مذكور ديده نمي شود و يا اينكه فقط غيرفعال (و به رنگ خاكستري) خواهد شد.

• Check Box با عنوان Checked اگر انتخاب شود، باعث خواهد شد تا كنار آن منو (آيتم) يك "چك‌مارك" ديده شود. (معمولا اين مشخصه در Run Time و بر حسب نياز تنظيم مي شود)

• توسط Shortcut مي توانيم يك ميانبر (Shortcut) براي يكي از آيتم‌ها درست كنيم..

• توسط Index مي توانيم آرايه اي از منوها را طراحي نماييم ( همانطوری که آرايه ای ازساير کنترلها درست می کرديم، يعنی بايد نام دو يا چند منو را يک نام واحد بگذاريم و Index متفاوت به هريک بدهيم.)

• و توسط NegotiatePosition مي‌توان نوع چيدن آيتم‌ها (راست چين، چپ چين، وسط چين) را تعيين نمود.

چند تذكر:

• براي دستيابي به مشخصه هاي منوها نيز مانند ساير كنترلها از نام آنها و يك نقطه(Dot) و سپس نام مشخصه مورد نظر استفاده مي كنيم. مثلا اگر منويي به نام mnuOpen داشته باشيم و بخواهيم آن را غيرفعال و يا مارك‌دار نماييم به ترتيب از دستورات زير استفاده خواهيم كرد:



mnuOpen.Enable = False

mnuOpen.Checked = True



• مشخصه WindowList در بحث MDI Forms خواهد آمد و از مشخصه HelpContentID نيز تنها زماني كه يك فايل HLP داشته باشيم مي‌توانيم استفاده كنيم.

• اگر بخواهيم بين دو آيتم از منويي يك خط جداكننده آورده شود (آنچه در ويندوز براي جداكردن بخشهاي مختلف يك منوي خاص معمول است) كافي است بين آن دو آيتم، يك آيتم Insert نماييم، نام آن را يك نام دلخواه (مثلا mnuLine) و عنوان (Caption) آن را يك منفي (كاراكتر "-" يا اصطلاحا Dash) بگذاريم.

• اگر بخواهيم براي شي خاصی يك PopUpMenu طراحي كنيم (منوهاي بازشونده‌اي كه وقتي بر روي شي كليك راست شود از آن خارج مي‌شود) كافيست يك منو (با آيتمهاي مورد نظر براي آن) را طراحي كنيم (و حتي در صورت نياز Visible آن را False كنيم) و در رويداد MouseDown از آن شي خاص، پس از اينكه شرط كرديم كليد زده شده كليد راست ماوس باشد (با استفاده از شرط برابري پارامتر Button از اين رويداد با مقدار ثابت VbRightButton)، با استفاده از دستور PopUpMenu، نام منوي مورد نظر را فراخواني مي كنيم يعني بايد چنين داشته باشيم:



Private Sub controlName_MouseDown (Button As Integer,…)

IF Button = VbRightButton Then

PopUpMenu mnuMenu1

End IF

End Sub



كه بجاي controlName نام آن كنترلي كه قرار است كاربر روي آن كليك راست نمايد و بجاي mnuMenu1 نام آن منويي كه قرار است به صورت PopUp آورده شود را ذكر مي كنيم.

[parsiyan_mohsen]

شناسایی CD ROM در سیستم :
دو تا لیبل بزارید توی فرمتون به نام های Lable1 و l1
این کدها رو به فرمتون اضافه کنین :


Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const Drive_Removable = 2
Private Const Drive_Fixed = 3
Private Const Drive_Remote = 4
Private Const Drive_CDRom = 5
Private Const Drive_RamDisk = 6
Private Sub Form_Load()
Dim R As Long
Dim AllDrives As String
Dim JustOneDrive As String
Dim Pos As Integer
Dim DriveType As Long
Dim CDFound As Boolean

AllDrives = Space$(64)
R = GetLogicalDriveStrings(Len(AllDrives), AllDrives)
AllDrives = Left$(AllDrives, R)
Do
Pos = InStr(AllDrives, Chr$(0))
If Pos Then
JustOneDrive = Left$(AllDrives, Pos)
AllDrives = Mid$(AllDrives, Pos + 1, Len(AllDrives))
DriveType = GetDriveType(JustOneDrive)
If DriveType = 5 Then
CDFound = True
Exit Do
End If
End If
Loop Until AllDrives = "" Or DriveType = Drive_CDRom

If CDFound Then
L1 = UCase(JustOneDrive)
Else
L1 = "No CDRom"
End If

End Sub

[parsiyan_mohsen]

برنامه ای که برایتان تهیه کرده ام ظرفیت درایوهای شما رو نشون میده که به نظر من خیلی میتونه کاربردی باشه :

[parsiyan_mohsen]

با کد های زیر برنامه شما به Startup میرود : (از این نمونه خیلی دیدم اما 60% از آن اصلاً عمل نمیکند.)

یه کامند بزارین تو فرمتون و این کد ها رو اضافه کنین :


Private Sub Cmd_Run_Click()

Dim hregkey As Long
Dim subkey As String
Dim stringbuffer As String

subkey = "Software\Microsoft\Windows\CurrentVersion\Run"

retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, KEY_WRITE, hregkey)
If retval <> 0 Then
Debug.Print "Can't open the subkey"
Exit Sub
End If
stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar
retval = RegSetValueEx(hregkey, "My App", 0, REG_SZ, ByVal stringbuffer, Len(stringbuffer))

RegCloseKey hregkey

End Sub



اینها رو هم تو یه ماژول کپی کنین :


Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal _
hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long

Public Const HKEY_CURRENT_USER = &H80000001
Public Const KEY_WRITE = &H20006
Public Const REG_SZ = 1

[parsiyan_mohsen]

خیلی از دوستان دوست دارن کار با TreeView رو یاد بگیرن ، گفتم آموزششو بزارم :
براي اضافه کردن اين کنترلها به جعبه ابزار ويژوال بيسيک اين کارا رو انجام بدين:
?- از منوي Project > Components را بزنيد يا کليدهاي crtl + T را بزنيد که در اين صورت کادر محاوره اي Components باز ميشود که در سربرگ(Tab) به نام Controls ليستي از کنترل هاي شناخته شده توسط ويژوال بيسيک مي آيد که شما بايد به دنبال Microsoft Windows Common Controls 6.0(SP4) a بگردين و تيک کنار اون رو فعال کنيد و بعد هم OK کنيد.
شما حتمآ حالت نمايش درختي را ديده ايد و بسيار از امکانتش بهرهمند شده ايد.
براي اينکه ياد بگيرين از اين کنترل چگونه استفاده کنيد ابتدا بايد بدانيد که ساختار درختي به صورتي است که در آن يک شاخه اصلي وجود دارد که شاخه هاي فرعي به آن منتصل شده اند. به شاخه هاي فرعي گره(Node)هم گفته مي شود. ما بايد ابتدا شاخه اصلي يا تنه را بسازيم و بعد گره ها را درست کنيم. براي يادگيري کامل به مثال زير توجه کنين:
ابتدا يک کنترل TreeView از جعبه ابزار به فرم اضافه کنيد . حالا اندازه آن را به طور دلخواه تغيير دهيد . روي فرم دابل کليک کنيد تا پنجره کدها و روال Form_Load باز شود.
حالا يک متغير از نوع Node به اسم MainNode تعريف مي کينم به اين صورت:
Dim MainNode as Node
و بعد هم یک متغیر دیگه به اسم ChidNode

Dim ChildNode as Node
بعد هم باید شروع کنیم به ست کردن متغیر ها . برای درست کردن شاخه اصلی به این صورت عمل میکنیم:

Set MainNode = TreeView1.nodes.add( , , "Main" , "Main") 'x
حالا ما شاخه اصلی رو ساختیم . بهتره الآن یه بار برنامه را اجرا کنید و نتیجه را ببینید.
شما میتونید به تعداد دلخواه شاخه درست کنید فقط کافیه به جای Main یک اسم دیگه بزارید.
برای ساختن گره ها یا شاخه های فرعی به جای ست کردن متغیر MainNode متغیر ChildNode را ست می کنیم . توجه داشته باشید که اگر بخواهید یک شاخه فرعی یا گره رو به یک تنه ( که در اینجا اسم تنه Main هست) متصل کنیم باید به صورت زیر عمل کنیم:

Set ChildNode = TreeView1.Nodes.Add("Main" , tvwChild , "Node1" , "Node1") 'x
همون طور که در خط بالا می بینید آرگومان اول Nodes.Add را برابر اسم تنه گذاشتیم و در آرگومان دوم از ثابت tvwChild استفاده کردیم که نشان دهنده این است که گره ای که قرار است اضافه شود زیر شاخه Main است. آرگومان سوم کلمه کلیدی یا یک شناسه است که برای گره ای که ساخته ایم قرار میدهیم در آرگومان چهارم هم خاصیت Text یا به عبارت دیگر کلمه ای که قرار است نمایش داده شود را اضافه کردیم.

در این حالت هم شما می تونید به تعداد دلخواه گره درست کنید فقط باید "Node1" رو در دو آرگومان آخر تغییر بدین.

توضیحات بالا در کل به این صورت است:


Private Sub Form_Load() 'x

Dim MainNode as Node
Dim ChildNode as Node

Set MainNode = TreeView1.Nodes.Add(,, "Main" , "Main") 'x
Set ChildNode = TreeView1.Nodes.Add ( "Main" , tvwChild , "Node1" , "Node1") 'x

End Sub

برای اینکه خوب بتونم آموزشم رو کامل کنم از یکی دو تا مثال استفاده می کنم.
نمایش درایو های موجود در My Computer .
یک پروژه جدید از نوع استاندارد باز کنید سپس یک کنترل TreeView به فرم برنام اضافه کنید و خاصیت آن را برابر TreeView1 قرار دهید .
حالا روی فرم برنامه دابل کلیک کنید تا روال Form_Load باز شود . کدهای زیر رو بنویسید.


Private Sub Form_Load()

Dim N as Node
Dim FSO , Drives
Set N = TreeView1.Nodes.Add(, , "HD" , "My Computer") 'x
set Fso = CreateObject("Scripting.FileSystemObject") 'x
Set Drives = Fso.Drives

For Each Drive In Drives
If Drive.isready then Set N = TreeView1.Nodes.Add("HD" , tvwChild , drive , drive) 'x
Next

End Sub

[parsiyan_mohsen]

این هم یه پروپرتی Override شده برای سایه دار کردن فرم ها . زمانی که یه کنترل خواستید بسازید این تکه کد خیلی به دردتون میخوره :


Private Const CS_DROPSHADOW As Integer = 131072
' Override the CreateParams property
Protected Overrides ReadOnly Property CreateParams() As System.Windows.Forms.CreateParams
Get
Dim cp As CreateParams = MyBase.CreateParams
cp.ClassStyle = cp.ClassStyle Or CS_DROPSHADOW
Return cp
End Get
End Property

[parsiyan_mohsen]

فضانام My در Visual Basic

Visual Basic همواه خصوصیات و امکانات جدیدی به منظور توسعه سریع نرمافزار که باعث بهبود بهرهوری، سهولت در استفاده و بالا بردن قدرت برنامه­نویسان میشود، ارائه مینماید. یکی از این امکانات My نام دارد. My امکان دسترسی به اطلاعاتی در مورد پروژه در حال اجرا و همچنین محیطی که پروژه در آن در حال اجرا میباشد را فراهم میسازد. مزیت مهم دیگر My در این است که به راحتی میتوان در قالب لیستهای پیشنهادی « IntelliSense » با امکانات آن کار کرد.
بالاترین سطح My، توسط اشیائی نشان داده میشود. هر کدام از این Objectها مانند یک فضانام و یا یک کلاس با اعضای Shared عمل مینمایند. در جدول زیر اشیاء سطح اول My و ارتباطات داخلی آنها مشخص شده است:



اعضای My عبارتند از:

Application: حاوی اطلاعاتی جامع و کاربردی در مورد پروژه جاری.

Computer: با این گزینه میتوان به خصوصیات و اطلاعات جامعی در مورد سخت افزارهای متصل به سیستم دست یافت.

Forms: با استفاده از این گزینه میتوان به تمامی فرمهای موجود در پروژه و طبعاً اطلاعات درونی آنها دست پیدا کرد.

Settings: از متدهای موجود در این گزینه میتوان تنظیمات پروژه را دستکاری نمود.

User: از این خصوصیت برای بدست آوردن اطلاعات در مورد کاربر جاری سیستم استفاده میشود.

Webservices: این خصوصیت برای فراهم کردن امکاناتی به منظور ایجاد و دستیابی به یک نمونه از وب سرویسهای XML که توسط پروژه جاری به آنها ارجاع شده است استفاده میکنیم.

Computer

این خصوصیت یکی از پرکاربردترین خصوصیات My می باشد. با به کارگیری این گزینه میتوان به راحتی هر چه تمامتر به اطلاعاتی در مورد وضعیت سخت­افزارهای متصل به سیستم درست پیدا کرد. این کار در یک خط کد و بدون انجام کارهای اضافی توسط برنامهنویس، صورت میپذیرد. به عنوان مثال برای اینکه متوجه شویم ماوس متصل به سیستم اسکرولدار است به راحتی میتوان از کد زیر استفاده کرد:

MsgBox(My.Computer.Mouse.WheelScrollLines)

از طریق Computers میتوان به سختافزارهایی مانند KeyBoard، Mouse، Audio و ... به راحتی دست پیدا کرد.

در ادامه چندین خصوصیت از computers را بررسی می كنیم:

1. Mouse: این شئ دارای 3 خصوصیت به شرح زیر میباشد:

ButtonsSwapped: تعیین جابجا شدن کلیک چپ و راست ماوس.

WheelExists: تعیین اسکرولدار بودن ماوس.

WheelScrollLines: تعیین تعداد سطوری که با یک بار حرکت ماوس رد می­شوند.

2. Keyboard: این شئ دارای 6 خصوصیت و یک متد می باشد:

AltKeyDown: تعیین میکند که آیا کلید Alt پایین نگه داشته شده است یا نه؟!

CtrlKeyDown: پایین بودن کلید Ctrl را بررسی می کند.

ShiftKeyDown: تعیین پایین و یا بالا بودن کلید Shift.

NumLock، CapsLock و ScrollLock: تعیین فعال یا غیرفعال بودن کلیدهای مرتبط.

متد ()SendKeys: از این متد برای ارسال ضربات کلید به محیط سیستم عامل استفاده میشود. به عنوان مثال ("+%")My.Computer.Keyboard.SendKeys باعث ارسال ضربات کلید Alt و Shift به سیستم میگردد. لذا زبان سیستم شما تغییر میکند. البته اگر بیش از یک زبان وجود داشته باشد.

3. Name: این خصوصیت از شئ Computer حاوی نام کامپیوتر است.

4. Screen: اطلاعات در مورد صفحه نمایش را در اختیار برنامهنویس قرار میدهد. این کلاس حاوی خصوصیات متعددی است که عبارتند از:

BitsPerPixel: میزان Color فعلی ویندوز را نشان میدهد. به عنوان مثال اگر این گزینه در ویندوز بر روی True Color (32 Bit) تنظیم باشد، عدد 32 و اگر بر روی High Color (16 Bit) تنظیم باشد عدد 16 برگشت داده می شود.

Bounds: حاوی خصوصیاتی به منظور تعیین محدوده کاری تنظیم شده می­باشد.

DeviceName: نامی که در سیستم برای مانیتور در نظر گرفته شده است را نمایش میدهد.

Primary: اگر دستگاه نمایش فعلی، دستگاه پیشفرض باشد true برگشت می دهد

WorkingArea: این گزینه اطلاعاتی راجع به میزان محیط کاری فعال در ویندوز را در بر دارد. تفاوت این گزینه با Bounds در این است که در Bounds مختصات کلی نمایش داده میشود اما در این گزینه، محیطی که واقعا میتوان از آن به عنوان Desktop استفاده کرد برگشت داده میشود. مثلاً در این گزینه ارتفاع نوار TaskBar از ارتفاع صفحه کسر میشود.

5. Clock: با استفاده از این شئ میتوان اطلاعات مفیدی در مورد ساعت سیستم بدست آورد. خصوصیات این شئ عبارتند از:

LocalTime: زمان جاری سیستم را برگشت میدهد.

GmtTime: زمان جاری سیستم را براساس زمان جاری GMT بیان میکند.

TickCount: مدت زمانی سپری شده از روشن بودن سیستم براساس میلی ثانیه را برگشت میدهد.

6. Audio: از این شئ برای پخش صوت دلخواه و همچنین صوتهای پیش فرض ویندوز میتوان استفاده کرد. این شئ فقط دارای 3 متد است:

Play: این متد دارای 4 سربارگذاری بوده و با آن میتوان یک فایل صوتی استاندارد را پخش نمود. برای این متد میتوان اطلاعات مسیر ذخیره سازی فایل را ارسال کرد و یا اطلاعات باینری موسیقی را ارسال نمود و یک Stream حاوی موسیقی ارسال نمود. همچنین نحوه پخش شدن را میتوان تنظیم کرد. میتوان کاری کرد که تا اتمام آهنگ فعالیتی صورت نگیرد و یا اینکه موسیقی در پس زمینه اجرا شود و کاربر بتواند به تعامل با برنامه ادامه دهد.

PlaySystemSound: از این متد برای پخش یکی از صداهای پیش فرض در ویندوز استفاده میکنیم. این متد دارای یک پارامتر است و برای مقداردهی آن از لیست پیشنهادی که باز میشود میتوانید استفاده کنید و یا اینکه یکی از اعضای Media.SystemSounds را ارسال کنید. به عنوان مثال Media.SystemSounds.Beep باعث پخش صدای بوقی از سیستم میشود.

Stop: پخش موسیقی را کنسل میکند.

7. FileSystem: این شئ حاوی متدهای فراوانی برای مدیریت فایلها و پوشه­ها میباشد. به علت سادگی و همخوانی نام متدها با عملی که انجام میدهند از ذکر آنها خودداری میکنیم. در این فایل چندین خصوصیت کاربردی به منظور یافتم مسیر جاری اجرای برنامه و ... نیز گنجانده شده است. مثلا My.Computer.FileSystem.CurrentDirectory مسیر جاری اجرای برنامه را برمی­گرداند. و یا از شئ Drives در این شئ برای مدیریت درایوهای کامپیوتر استفاده میشود. همچنین خصوصیت تحت عنوان SpecialDirectories در این شئ وجود دارد که آدرس پوشههای مهم سیستم مانند Desktop، ProgramFiles، Windows، Temp، Programs و ... را برگشت میدهد.

8. Network: این شئ حاوی متدها و خصوصیاتی برای کنترل شبکه می­باشدو با متدهای موجود در این شئ میتوانید اقدام به دانلود و ... نیز بکنید.

9. Port: حاوی اطلاعات راجع به پورتهای سیستم و همچنین تعامل با آنها.

10. ClipBoard: حاوی متدهایی برای کنترل و دستکاری کلیپ بورد سیستم. مثلا با متد ContainsText() میتوان پی برد که اگر گزینه Paste در برنامه فشار داده شود آیا متن در حافظه وجود دارد یا خیر؟ متدهای این کلاس به صورت خلاصه عبارتند از:

()Clear: پاک کردن حافظه کلیپبورد.

ContainsText()، ContainsAudio و متدهایی که با Contains آغاز میشوند: بررسی اینکه شئ موجود در حافظه از نوع مد نظر می باشد یا نه؟

متدهای Get: از این متدها برای دریافت اطلاعات موجود در حافظه متناسب با نوع متد برگشت میدهد

متدهای Set: میتوان حافظه را از درون برنامه در حال اجرا ست نمود.

11. Info: این شئ حاوی اطلاعاتی کلی در مورد سیستم است. اطلاعاتی از قبیل نام کامل سیستم عامل، میزان کل حافظه Ram و حافظه مجازی، میزان در دسترس این حافظهها، نوع سیستم عامل و ورژن سیستم عامل و ... . به عنوان مثال (MsgBox(My.Computer.Info.OSFullName نام کامل سیستم عامل را نمایش میدهد

12. Registery: حاوی متدهایی برای کار با رجیستری میباشد. از متدها و اشیاء درونی این شئ برای دستکاری قسمتهای مختلف Registery میتوان استفاده کرد.

[parsiyan_mohsen]

تولید اعداد تصادفی در بازه خاص :


Public Command As String
Public Permission As String
Public DB1 As Database
Public RS1 As Recordset
Public SL As String 'Select Lesson
Public Cl As String 'Code of Collegian
Public asd As String
Option Explicit

'//===============================================
'//This function create Random number in special range
'//Count ==> count of number that must created
'//Min ==> Minimume of number that can be created
'//Max ==> Maximume of number that can be created
'//Result() ==> A byref array for put result in it and return to user

Public Function Random_X(ByVal Count As Long, ByVal Min As Long, ByVal Max As Long, ByRef Result() As Long, ByVal Sort_Array As Boolean) As Boolean
Dim i As Long
Dim Top_Array As Long
Dim Rand_Num As Long
Randomize '//Randomize Timer
'//============================
'//First check that count in range (MAX-MIN)
If Count > (Max - Min) Then
Random_X = False
Exit Function
Else
Random_X = True
End If
'//============================
Top_Array = 0
ReDim Result(Count - 1) '//Redim Empty Array and Fit it to Count
For i = LBound(Result) To UBound(Result)
Repeat:
Rand_Num = Rnd() * Max
Rand_Num = Rand_Num + Max '//Go Number larger than max
Do While (Rand_Num < Min Or Rand_Num > Max)
Rand_Num = Rand_Num - (Max - Min) '// IF Rand number is out of range , come it in range
Loop
If In_Array_X(Result, Rand_Num, i) = False Then '//IF Not exist then push it into array
Result(i) = Rand_Num
Else
GoTo Repeat
End If
Next
If Sort_Array = True Then Sort Result '//If Sort =True then Sort result array
End Function

'//=======================================
'//This function get a byref array and a num
'//Check the num exist in array

Public Function In_Array_X(ByRef Arr_Name() As Long, ByVal Num As Long, ByVal Top_Arr As Long) As Boolean

Dim i As Long

In_Array_X = False

If Top_Arr > UBound(Arr_Name) Then Top_Arr = UBound(Arr_Name)

For i = LBound(Arr_Name) To Top_Arr

If Arr_Name(i) = Num Then

In_Array_X = True
Exit For

End If

Next

End Function
'//=======================================
'//This Function get a byref array and sort it

Public Sub Sort(ByRef Sort_Arr() As Long)
Dim i As Long, j As Long
Dim Temp As Long
For i = UBound(Sort_Arr) - 1 To LBound(Sort_Arr) Step -1
For j = 0 To i Step 1
If Sort_Arr(j) > Sort_Arr(j + 1) Then
Temp = Sort_Arr(j)
Sort_Arr(j) = Sort_Arr(j + 1)
Sort_Arr(j + 1) = Temp
End If
Next
Next
End Sub

طرز استفاده از تابع :


Dim IfSuccess As Boolean
Dim Result() As Long

IfSuccess = Random_X(1, 100, 1000, Result, True)
Text1.Text = Result(0

[parsiyan_mohsen]

با این کد می تونید یک فایل رو در شبکه با استفاده از وینسوک ارسال کنید :


Public Sub SendData(ByVal sFile As String, ByVal sSaveAs As String, ByVal tcpSend As Winsock)

On Error GoTo ErrHandler

Dim sSend As String, sBuf As String

Dim ifreefile As Integer

Dim lRead As Long, lLen As Long, lThisRead As Long, lLastRead As Long

Dim strData As String

tcpSend.GetData(strData)

ifreefile = FreeFile



' Open file for binary access:

Open sFile For Binary Access Read As #ifreefile

lLen = LOF(ifreefile)



' Loop through the file, loading it up in chunks of 64k:

Do While lRead < lLen

lThisRead = 65536

If lThisRead + lRead > lLen Then

lThisRead = lLen - lRead

End If

If Not lThisRead = lLastRead Then

sBuf = Space$(lThisRead)

End If

Get #ifreefile, , sBuf

lRead = lRead + lThisRead

sSend = sSend & sBuf

sBuf = Space$(0)

Loop

lTotal = lLen

Close(ifreefile)

bSendingFile = True

'// Send the file notification

tcpSend.SendData("FILE" & sSaveAs)

DoEvents()

'// Send the file

tcpServer.SendData(sSend)

DoEvents()

'// Finished

tcpSend.SendData("FILEEND")

bSendingFile = False

MMControl1.FileName = "FileDone.wav"

MMControl1.Command = "Open"

MMControl1.Command = "Play"

Exit Sub

ErrHandler:

MsgBox "Err " & Err & " : " & Error

End Sub



Private Sub tcpServer_DataArrival(ByVal bytesTotal As Long)

Dim strData As String

Dim ifreefile



' DoEvents

tcpServer.GetData(strData)

If Right$(strData, 7) = "FILEEND" Then

bFileArriving = False

lblProgress = "Saving File to " & App.Path & "\" & sFile

sArriving = sArriving & Left$(strData, Len(strData) - 7)

ifreefile = FreeFile

MMControl1.FileName = "File.wav"

MMControl1.Command = "Open"

MMControl1.Command = "Play"

Open sFile For Binary Access Write As #ifreefile

Put #ifreefile, 1, sArriving

Close #ifreefile

ShellExecute 0, vbNullString, App.Path & "\" & sFile,

vbNullString, vbNullString, vbNormalFocus

lblProgress = "Complete"

ElseIf Left$(strData, 4) = "FILE" Then

bFileArriving = True

sFile = Right$(strData, Len(strData) - 4)

ElseIf bFileArriving Then

lblProgress = "Receiving " & bytesTotal & " bytes for " & sFile & ""

>from " & tcpServer.RemoteHostIP

sArriving = sArriving & strData

MMControl1.FileName = "FileDone.wav"

MMControl1.Command = "Open"

MMControl1.Command = "Play"

End If

End Sub

[parsiyan_mohsen]

با این آموزش شما میتونید یه سری اطلاعات رو یه جای خاص از رجیستری ذخیره کنید که مثلا برای ثبت تنظیمات کاربر میتونید مورد استفاده قرار بدید. به نظر من خیلی کاربردی هست :
ذخیره اطلاعات :


FontName=GetSetting(My.Application.Info.AssemblyNa me, "Appearance", "Font","")

ColorName=GetSetting(My.Application.Info.AssemblyN ame, "Appearance", "Color","")

بازیابی اطلاعات :


FontName=GetSetting(My.Application.Info.AssemblyNa me, "Appearance", "Font","")

ColorName=GetSetting(My.Application.Info.AssemblyN ame, "Appearance", "Color","")



مکان ذخیره :
HKEY_CURRENT_USER\Software\VB and VBA Program Settings

[parsiyan_mohsen]

انجام اعمال متداول در رجیستری خیلی جالبه :


Imports Microsoft.Win32





Private Sub button1_Click(ByVal sender As Object, ByVal e As EventArgs) Handles Button1.Click

' // Create SubKey

Registry.LocalMachine.CreateSubKey("Software\Sinpin", RegistryKeyPermissionCheck.ReadWriteSubTree)



'//Create Key and Set Value

Dim reg As RegistryKey = Registry.LocalMachine.OpenSubKey("Software\Sinpin", True)

reg.SetValue("DWord", "1", RegistryValueKind.DWord)

reg.SetValue("ExpandString", "1", RegistryValueKind.ExpandString)

reg.SetValue("QWord", "1", RegistryValueKind.QWord)

reg.SetValue("String", "1", RegistryValueKind.String)

reg.SetValue("Unknown", "1", RegistryValueKind.Unknown)



'// Delete Key

reg.DeleteValue("DWOrd")



'// Delete SubKey

Registry.LocalMachine.DeleteSubKey("Software\Sinpin")



'// Read Key Value

Dim val As String = reg.GetValue("QWord").ToString()



'// Retrieve All Keys

For Each s As String In reg.GetValueNames()

MessageBox.Show(s)

Next



End Sub

[parsiyan_mohsen]

روش تغییر پسورد پایگاه داده Access از طریق VB :
این بار قرار است روشی رو به شما عزیزان آموزش بدم که با استفاده از آن می توانید کلمه عبوری را که روی پایگاه داده Access خودتان قرار داده اید از طریق کد نویسی در ویژوال بیسیک تغییر دهید . برای انجام این عمل باید مراحل زیر را انجام دهید .


1. ابتدا یک پروژه را در VB باز کنید . سپس از منوی Project گزینه References را انتخاب کنید تا دیالوگی نمایش داده شود . از لیستی که مشاهده می کنید گزینه ( Microsoft DAO 3.51 Object library ) را علامت بزنید . البته این در صورتی است که پایگاه داده شما پایین تر از فرمت Office 2003 باشد . ( مثلا Office 2000 ) . در غیر این صورت باید گزینه ( MicroSoft DAO 3.6 Object Library )علامت بزنید . تا احیانا با خطایی مواجه نشوید . ( نسخه 3.6 میتواند بهترین انتخاب باشد ).


2. سپس مثلا یک دکمه روی فرم خود گذاشته و نام آن را به Cmd_PassChange و عنوان آن را به PassChange تغییر دهید . حال کدهای زیر را داخل آن بنویسید یا کپی کنید :


Dim db As DAO.Database

("Set db = DBEngine.OpenDatabase(App.Path & "\Test.mdb", True, False, ";pwd=media

"db.NewPassword "media", "ali

db.Close

در این مثال ابتدا ما یک متغیر ( db ) را از نوع کتابخانه DAO تعریف می کنیم . در دستور Set کردن پایگاه داده Access توجه داشته باشید که چون پایگاه داده ما از قبل دارای کلمه عبور است ، ما مجبوریم برای ورود به آن از کلمه عبور ( در این مثال media ) استفاده کنیم . همچنین دقت داشته باشید که در این دستور حتما باید مقدار ورودی Option ( مقدار دوم که تعیین می کند ما به تنظیمات پایگاه داده دسترسی داشته باشیم یا نه) مقدار True باشد . درغیر این صورت از تغییر کلمه عبور جلوگیری خواهد شد . در دستور سوم هم که مشاهدی می کنید ، اولین پارامتر ورودی کلمه عبور قبلی و دومین پارامتر ورودی کلمه عبور جدید شما خواهد بود . خط آخر هم در اصطلاح برای بستن پایگاه داده به کار می رود .

[parsiyan_mohsen]

اعمال مشخصه RightToLeft به کنترلهایی که فاقد این مشخصه اند :
در این روش شما میتونید به هر کنترلی این مشخصه رو اعمال کنید، حتی کنترلهایی که فاقد این مشخصه هستند مثل DirListBox به صورت از راست به چپ در میان. درضمن اگه با فرمتون اینکارو بکنید میبینید که واقعاً به صورت از راست به چپ درمیاد یعنی دکمه Close، Minimize و Maximize از سمت راست فرم به سمت چپ فرم انتقال پیدا میکنن.

یک پروژه جدید باز کنید و یک DirListBox به فرمتون اضافه کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :


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

Private Sub Form_Load()
SetWindowLong Me.hWnd, -20, GetWindowLong(Me.hWnd, -20) Or &H400000
SetWindowLong Dir1.hWnd, -20, GetWindowLong(Dir1.hWnd, -20) Or &H400000
End Sub


حالا برنامه رو اجرا کنید و شاهد تغییراتی که در حالت معمولی غیر ممکن بودن باشید.

این کد رو اگه خواستین تغییر بدین فقط یه شرط داره اونم اینه که کنترلی که میخواین تغییرات روش اعمال بشه باید خاصیت hWnd رو داشته باشه.

[parsiyan_mohsen]

تنظیم ساعت سیستم با ویژوال بیسیک :
یه تایمر و فرمتون بذارین و اینتروال اون رو روی 1000 تنظیم کنید و کد زیررو توی قسمت جنرال فرمتون قرار بدین


Dim TimeStop

Private Sub Form_Load()
TimeStop = Time
End Sub

Private Sub Timer1_Timer()
Time = TimeStop
End Sub

توی این کد وقتی فرم اجرا میشه زمان وارد TimeStop میشه بعدش توسط تایمر زمان به TimeStop تنظیم میشه که به عبارتی زمان رو نگه میداره

حالا میخوایم زمان رو تنظیم کنیم:
یهCommand رو فرمتون بذارین بعد از این کد استفاده کنید


Private Sub Command1_Click()
Dim H, Min, Sec, AMorPM
H = InputBox("Type Hour...")
Min = InputBox("Type Minute...")
Sec = InputBox("Type Second...")
AMorPM = InputBox("AM time or PM time")
Time = H & ":" & Min & ":" & Sec & AMorPM
End Sub

[parsiyan_mohsen]

ثبت تنظیمات و اطّلاعات برنامه در رجیستری :
خب اوّل یک مثال میزنم و بعد میرم سره آموزش تا بهتر یاد بگیرید.



یک پروژه جدید باز کنید و یک Command Button و یک TextBox بذارید تو فرمتون و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :


Private Sub Command1_Click()



SaveSetting App.Title, "Setting", "Value", Text1.Text



End Sub



Private Sub Form_Load()



Text1.Text = GetSetting(App.Title, "Setting", "Value", "Hello")



End Sub

برنامه رو اجرا کنید و هر چی دلتون میخواد تو TextBox وارد کنید و بعد کلید Command1 رو بزنید و از برنامه خارج بشید. حالا اگه دوباره برنامه رو اجرا کنید میبینید متنی که دفعه قبل وارد کرده بودید سره جاشه و پاک نشده.
به نظرم جالبه

[parsiyan_mohsen]

تريگرها درSQL Server در ويژوال بيسيك6 :
تريگر نوع خاصي از روال ذخيره شده است و در هنگام تغيير داده اي كه براي حفاظت از آن طراحي شده است فعال مي گردد. تريگرها با جلوگيري از تغييرات غير معتبر يا ناسازگار در داده ها به حفظ يكپارچگي داده اي كمك مي كنند. فرض كنيد دو جدول customer و orders در اختيار داريد بنابراين مي توانيد تريگري ايجاد كنيد كه با ايجاد هر سفارش جديد، اعتبار شماره مشتري آن را كنترل كند. همچنين مي توانيد تريگري ديگري ايجاد كنيد كه در صورت حذف يك مشتري جدول orders‌ را كنترل كرده و در صورت وجود سفارش براي آن مشتري فرآيند حذف مشتري را متوقف سازد.
تريگرها مي توانند قواعد كاري پيچيده تري را نسبت به قيود اعمال كنند. براي مثال يك تريگر insert مي تواند در هنگام درج ركورد جديد به سفارشات فعال شود و وضعيت پرداخت مشتري را بررسي و نوع پرداخت مناسب وي را تعيين كند.
تريگرها پارامتر ندارند و صريحا فعال نمي شوند و براي فعال سازي آنها تغييرات داده اي لازم است.
تريگرها را مي توان تا 32 سطح تودرتو تعريف كرد. اين تريگرها به شكل زير عمل مي كنند:
براي مثال تريگر جدول orders يك ورودي به جدول حسابهاي دريافتي اضافه مي كند و اين ورودي به نوبه خود تريگر ديگري را براي بررسي وضعيت مشتري فعال مي نمايد. يك تريگر به روز رساني جدول را انجام مي ده و همين امر تريگر ديگري را فعال مي كند.
بطور پيش فرض تمامي تريگرها (UPDATE,DELETE,INSERT)پس از تغييرات داده اي فعال مي شوند و به تريگر AFTER‌ معروف مي باشند. در ويرايش هاي قبلي SQL Server‌ تنها اين نوع تريگر موجود بوده است. در SQL Server 2000‌ نوع ديگري به نام INSTEAD OF ‌ معرفي شده است كه بجاي تغييرات داده اي موردنظر فعال مي شود.
از نقطه نظر كارائي، تريگرها سربار زيادي ندارند. بيشتر زمان اجراي يك تريگر براي ارجاع به ساير جدول بكار مي رود. اين ارجاع در صورت وجود جداول در حافظه سريع و در صورت نيار به خواندن از ديسك كمي كندتر خواهد بود.
تريگرها بخشي از يك تراكنش (transaction) محسوب مي شوند. اگر تريگر يا هر بخشي از تراكنش با شكست مواجه شود كل تراكنش عقبگرد مي شود.

درك جدول Deleted و Inserted

تريگرها از دو جدول inserted و deleted استفاده مي كنند. اين جداول ساختار مشابهي با جدول پايه يا جدول trigger‌ كه تريگر در آن ايجاد مي شود دارند. اين دو جدول در حافظه RAMقرار مي گيرند و جداول منطقي هستند . اگر ركورد جديدي را به جدول پايه اضافه كنيد اين ركورد هم در جدول پايه و هم در جدول inserted ثبت مي شود. وجود مقادير در دسترس در جدول inserted‌به شما امكان مي دهد كه نيازي به ايجاد متغير براي نگهداري اطلاعات نداشته باشيد و به اطلاعات دلخواه دسترسي بيابيد. هنگام حذف يك ركورد، ركورد حذف شده در جدول deleted قرار مي گيرد. به روز رساني نيز يك حذف و درج متوالي است. اگر ركوردي را به روز رساني كنيد، ركورد اصلي در جدول deleted و ركورد تغيير يافته در جدول پايه و جدول inserted ذخيره مي شود.
نكته : شما نمي توايند محتواي جداول inserted و Deleted را ببينيد.
اما براي اينكار مي توانيد با استفاده از تريگري محتواي اين جداول را ببينيد.كه در قسمتهاي بعدي شرح داده ميشود.

ايجاد تريگرها با دستور CREATE TRIGGER
نگارش ايجاد تريگرها به شرح زير است :


CREATE TRIGGER [owner.]trigger_name
ON [owner.]table_name | view_name
{FOR..AFTER | INSTEAD OF] {INSERT | UPDATE | DELETE}
[WITH ENCRYPTION]
AS sql.statements

يك جدول مي تواند هر تعداد تريگر از انواع DELETE, UPDATE ,INNSERT داشته باشد. هر عمل را مي توان در يك يا چند تريگر ذخيره كرد. اگر عملي در چند تريگر ذخيره شود بايد نام تريگرها منحصر بفرد و يكتا باشد. براي مثال مي توانيد تريگري به نام trInsupAuthors را بر روي جدول authors براي عمل حذف بر روي همين جدول ايجاد كنيد. براي تغيير تريگر كافيست از محيط enterprise روي جدول موردنظرراست كليك كرده گرينه ي Manage Trigger را بزنيد و از ليست كشويي تريگر موردنظر خود را انتخاب كرده و آنرا ويرايش نماييد. و از محيط كوئري آناليز هم توسط دستور ALTER TRIGGER تريگر را ويرايش كنيد يا ابتدا آنرا حذف نموده و دوباره ايجاد كنيد.
توجه : تغيير تريگر با دستور ALTER TRIGGER، سبب جايگزيني كامل تريگر قديم با تريگر جديد مي شود. با حذف يك جدول، تريگرها موجود آن نيز به شكل خودكار حذف مي شوند.
قوانين حاكم بر تريگرها:
· تريگر را نمي‌توان براي جداول موقت ايجاد كرد اما مي‌تواند به ديدها و يا جداول موقت ارجاع داشته باشد.
· تريگر مجموعه‌ جواب (resultest) باز نمي‌گرداند بنابراين هنگام استفاده از دستورات select احتياط كنيد. بكارگيري عبارت if exists‌ به عنوان بخشي از دستور select در كد تريگر متداول است.
· تريگر براي حفظ يكپارچگي داده‌اي، ارجاعي و كپسوله كردن قوانين كاري بكار ميرود.
· بكارگيري گزينه with encryption‌ سبب مي‌شود تريگرها در جدول syscomments‌ به شكل رمز شده نگهداري شوند.
· دستورات writetext‌ تريگرها را فعال نمي‌كنند. اين دستورات براي تغييرات داده‌اي متني (text)‌ و تصوير (image) بكار مي‌رود و در فايل گزارش تراكنشها ثبت نمي‌شود.
· دستورات SQL‌ زير را نمي‌توان در تريگرها بكار برد: همه انواع دستورات CREATE‌، همه دستورات DROP و دستورات ALTER TABLE, ALTER DATABASE ,TRUNCATE TABLE, GRANT, TRANSACTION, LOAD DATABASE, ROCONFIGURE REVOKE, STATISTICS, UPDATE STATISTICS , SELECT INFO, و كليه دستورات DISK
· دستورات عقبگرد شده تراكنشها در تريگرها مي تواند نتايج غير منتظره‌اي را در برنامه ها ايجاد كند.

تريگرهاي Insert و UpdateوDelete
حال به يك نمونه تريگر براي دستورات INSERT و UPDATE جدول توجه كنيد:


CREATE TRIGGER trAddAuther
ON authors
FOR INSERT, UPDATE
AS raiserror (“%d rows have been modified”, 0,1, @@rowcount)
RETURN



CREATE TRIGGER trDelAuthors
ON authors
FOR DELETE AS
raiserror(“%d rows are going to be deleted from this table!”,0 , 1 , @@rowcount)

توجه كنيد كه پيام را در صورتي مشاهده مي كنيد كه عمل حذف را در محيط كوئري آناليز انجام دهيد.
تريگري براي ديدن محتواي جداولinserted و Deleted


CREATE TRIGGER tr24 ON Teacher


FOR DELETE ,update,insert


AS


select * into del from deleted


select * into insl from inserted

نام تريگر بالا tr24 است. كه بر روي جدول teacher ساخته شده است. خط دوم يعني وقتي عمليات اضافه يا حذف يا ويرايش بر روي جدول teacher اتفاق افتاد اين تريگر فراخواني شود..خط چهارم ركوردهاي موجود در جدول Deleted را در جدول del مي ريزد و خط پنج هم محتواي جدولinserted را در جدولins مي ريزد.
توجه كنيد كه جدولهايinsو del نبايد وجود داشته باشند وگرنه پيام خطا ميدهد.

اعمال يكپارچگي داده‌اي با تريگرها


تريگرها براي اعمال يكپارچگي داده‌اي در پايگاه داده بكار مي‌روند. در گذشته يكپارچگي ارجاعي صرفا از طريق تريگرها تامين مي‌شد. در ويرايشهاي اخير SQL Server اينكار را مي‌توان با قيد يكپارچگي ارجاعي انجام داد اما تريگرها كماكان براي كپسوله كردن قواعد كاري و تغييرات پله‌اي پايگاه داده مفيدند. يك تغيير پله‌اي مي‌تواند با تريگر ايجاد شود. فرض كنيد يك فروشگاه ديگر فعاليت نمي‌كند. شما مي‌توانيد تريگري ايجاد كنيد كه ابتدا اين فروشگاه را از جدول stores حذف كند و سپس كليه فروشهاي مربوط به آن را از جدول sales حذف نمايد


اعمال يكپارچگي ارجاعي

تريگرها براي اعمال يكپارچگي ارجاعي نيز بكار مي‌روند. اين كار هدف اصلي آنها در پايگاه داده است. بخصوص براي حذفها و به روز رساني پله‌اي مفيدند. تريگرها در پايان تغييرات داده‌اي كنترل مي‌شوند در حاليكه قيود در ابتدا كنترل مي‌شوند. اگر قيدي نقض شود. هيچ تريگري فعال نمي‌شود. تريگر زير يكپارچگي داده‌اي را اعمال مي‌كند. از طريق اين تريگر مطمئن مي‌شويم كه در صورت درج يك ركورد جديد در جدول Sales حتما كد فروشگاه معتبر آن در جدول stores وجود دارد.


CRETAE TRIGGER trInsUpdSales
On tblSales
FOR INSERT, UPDATE AS
IF(SELECT COINT(*) FROM tblStores , inserted
WHERE tblStores.stor_id = inserted.stor_id) =0
BEGIN
PRINT ‘The stor_id you have entered does not exist’
PRINT ‘in the stores table’
ROLLBACK TRANSACTION
END

اين تريگر براي هر دستور مجزاي INSERT يا UPDATE‌ بر روي جدول tblSales بخوبي كار مي‌كند. اما اگر دستور SELECT INTO را اجرا كنيد، تريگر ممكن است كاملا درست فعال نشود. وقتي با چندين سطر سروكار داريد بايد مطمئن شويد تعداد سطرهاي درج شده stor_id‌ با تعداد فروش‌هايي كه اضافه كرده‌ايد برابر باشد. حال تريگر را به شكل زير تغيير مي‌دهيم:


DROP TRIGGER trInsUpdSales
GO
CRETAE TRIGGER trInsUpdSales
On tblSales
FOR INSERT, UPDATE AS
DECLARE @rc int
SELECT @rc = @@rowcount
IF(SELECT COINT(*) FROM tblStores , inserted
WHERE tblStores.stor_id = inserted.stor_id) =0
BEGIN
PRINT ‘The stor_id you have entered does not exist’
PRINT ‘in the stores table’
ROLLBACK TRANSACTION
END
IF(SELECT COINT(*) FROM tblStores , inserted
WHERE tblStores.stor_id = inserted.stor_id) <>@rc
BEGIN
PRINT ‘Not all sales have a valid stor_id’
PRINT ‘in the stores table’
ROLLBACK t TRANSACTION
END

بكار گيري تريگرهاي INSTEAD OF
هنگام استفاده از تريگرهاي INSTEAD OF كد اصلي ايجاد تغييرات در جدول اجرا نمي شود بلكه كد تريگر اجرا مي‌شود. براي مثال شما مي‌توانيد تريگري را براي جدول authors ايجاد كنيد كه به كاربران اطلاع دهد مولفين را نمي‌توان حذف كرد. اين كار با تريگر معمول FOR،AFTER نيز قابل انجام است. اما مستلزم آن است كه تغييرات واقعي در ابتدا اعمال شوند سپس در كد تريگر عقبگرد شوند. اگر كد تريگر INSTEAD OF را بكار بريد، عمل به روز رساني انجام نمي‌شود و طبيعي است اين تريگر كاراتر است. به مثال زير توجه كنيد.


USE pubs
GO
CREATE TRIGGER trlO_DelAuthors
ON authors INSTEAD OF DELETE AS
PRINT ‘you can not delete authors from the authors table!’

براي تست تريگر سعي كند مولفي با نام خانوادگي white را حذف كنيد:



USE pubes
GO
DELETE authors WHERE au_lname = ‘white’

جمع آوري اطلاعات تريگرها

با اجراي روال ذخيره شده sp_helptext مي‌توانيد متن دستور تريگر را مشاهده كنيد. البته تريگرهاي رمز شده ركوردي در جدول Syscomments ندارند. در حالت كلي نبايد هيچ شيئي را رمزنگاري كنيد. مگر آنكه واقعا مجبور باشيد. هنگام ارتقا پايگاه داده كليه اشياء رمزنگاري شده بايد حذف و مجددا ايجاد شوند. اما اشياء رمزنشده بطور خودكار به ويرايش جديد ارتقاء داده مي‌شوند.

[parsiyan_mohsen]

تشخیص ادمین بودن کاربر جاری در ویندوز

اگه زمانی خواستید این موضوع رو بفهمید کافیه که از تابع API ی که در shell32 تعریف شده استفاده کنید. صورت کلی این تابع چنین است:

Private Declare Function IsUserAnAdmin Lib "shell32" () As Long
تحت ویندوز 2000 ممکنه که شما خطای با عنوان Can't find DLL entry point دریافت کنید که بهتر است که معرفی تابع را بدین گونه انجام دهید:

Private Declare Function IsUserAnAdmin Lib "shell32" Alias "#680" () As Long

[parsiyan_mohsen]

فیلتر کردن بعضی از کلید های صفحه کلید :


Private Sub Form_KeyPress(KeyAscii As Integer)
Dim svalid As String
svalid = "0123456789"
If InStr(svalid, Chr(KeyAscii)) = 0 Then
KeyAscii = 0
MsgBox "Not valid Keys.please Press 0-9 keys"
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
MsgBox "The form cannot be close.farzad dh."
Dim leftI As Long
Dim rightI As Long
leftI = Form1.Left + 1000
rightI = Form1.Top + 1000
Dim a As New Form1
a.Width = Me.Width
a.Height = Me.Height
a.Left = leftI
a.Top = rightI
a.Show
End Sub

[parsiyan_mohsen]

ساختن جدول در بانک اطلاعاتی :
از منوی project گزینه refrences رو انتخاب کنید - بعد اونجا گزینه Microsoft ActiveX Data Objects 2.0 library پيدا کنيدو تيک بزنيد - Adodc مورد نظرتون رو هم با دیتابیس set کنید - بعد :


Dim db_file As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim NumRec As Integer

Set conn = New ADODB.Connection
conn.ConnectionString = Adodc1.ConnectionString
conn.Open

On Error Resume Next
conn.Execute "DROP TABLE Jadid"
On Error GoTo 0

conn.Execute "CREATE TABLE Jadid(" & "One INTEGER NOT NULL," & "Two VARCHAR(40) NOT NULL," & "Three VARCHAR(40) NOT NULL)"

conn.Execute "INSERT INTO Jadid VALUES (1,'4','7')"
conn.Execute "INSERT INTO Jadid VALUES (2,'5','8')"
conn.Execute "INSERT INTO Jadid VALUES (3,'6','9')"

Set rs = conn.Execute("SELECT COUNT (*) FROM Jadid")
NumRec = rs.Fields(0)

conn.Close

MsgBox "Created ... "

[parsiyan_mohsen]

نحوه تولید DLL با ویژوال بیسیک

بعنوان یک زبان برنامه‌نویسی با توسعه سریع، ویژوال بیسیک نظر خیلی از برنامه‌نویسان را از جهت سادگی به خود معطوف کرد. برنامه‌نویسی با ویژوال بیسیک در کمترین زمان صورت می‌گیرد حال آنکه در مقابل زبانهایی چون C و ++C اغلب اوقات به روزها کار مفید نیاز است.
اما بیشترین انتقادی که برنامه‌نویسان از ویژوال بیسیک دارند در این است که قادر به تولید کتابخانه‌های پویا (DLL) نیست. حقیقتا این نظر مورد قبول است که نمی‌توان این نوع فایلها را در کنار فایلهای اجرایی(Exe) یا ActiveX Exe تولید کرد.
در این مقاله ما قصد داریم که نگاه دقیقی به نحوه تولید فایلهای اجرایی در ویژوال بیسیک یندازیم و بعد با طی مراحل ساده‌ای موفق به ایجاد فایلهای DLL بشویم تا از زیر بار این انتقاد نیز رهایی یابیم.
قبلا به این موضوع اشاره شد که فایهای DLL آن دست از برنامه‌هایی هستند که یکبار نوشته می‌شوند و در پروژه‌های بعدی بکرات می‌تواند از آنها استفاده برد. چیزی که هسته ویندور را تشکیل می‌دهد اینگونه فایلها هستند. علاوه بر آن تکنیک‌هایی وجود دارد که شما را قادر می‌سازد تا برنامه‌هایی بنویسید که قادرند خود را بروز برسانند و یا خود ترمیم باشند. بهتر از آن اینکه برنامه‌ای بنویسید که با الحاق اینگونه فایلها بدان قدرت و امکانات جدید بدان افزود. همانند نرم‌افزارهای رایج از جمله Winamp.

کتابخانه‌های پویای قابل اتصال (DLL) چه هستند؟

یک DLL مجموعه‌ای از توابع و پروسه‌هایی است که می‌تواند از برنامه یا DLLهای نظیر خود فراخوانده شود.

استفاده از اینگونه کتابخانه‌های دو مزیت اصلی دارد:
1- امکان به اشتراک گذاری از کد را فراهم می‌سازند. یک DLL می‌تواند مورد استفاده خیلی از برنامه‌های قرار گیرد. بعنوان مثال کتابخانه Win32 API نمونه‌ای از این سری فایلها است. بعلاوه از زمانی که پروسه‌های گوناگون قادر به فراخوانی یک DLL واحد هستند امکان به اشتراک گذاری کد‌ها و روتین‌ها فراهم آمده است. یک فایل DLL تنها یکبار به درون حافظه لود می‌شود و بارها توسط پروسه‌های گوناگونی مورد استفاده قرار می‌گیرد و این یعنی مدیریت حافظه بهتر.

2- مزیت دیگر امکان نوشتن برنامه‌ها بصورت اجزای منفصل است که این اجزا خود قابل تعویض با نگارش‌های جدیدتر جهت توسعه نرم‌افزار خواهند بود بدون اینکه خطی از کد برنامه اصلی دگرگون شود.

با این توصیف فایلهای کتابخانه‌ای درونی که در پروژه‌های مورد استفاده قرار می‌گیرد در صورت تغییر نیاز هست تا پروژه اصلی دوباره کمپایل شود تا بتوان با آن ارتباط بر قرار کرد. اما در DLL ها چون بصورت پویا و قابل انعطاف نوشته شده‌اند این اتصال در بیرون از بدنه اصلی و درست در زمان فراخوانی آن قبیل از متدها و توابع شکل می‌گیرد و این خود تفاوت آشکار از مزیت این گونه از فایلها می‌باشد.همچنین یک فایل DLL می‌تواند حاوی توابعی باشد که فقط مورد استفاده خود هست و از درون به آن دسترسی نخواهیم داشت و آندسته از تابعی را که نیاز هست معرفی می‌کنیم تا از بیرون بدان دسترسی داشته باشیم. در این مرحله نیاز به معرفی در فایلهای Def هست که در پروژه‌های C و C++ مورد استفاده قرار می‌گیرد.

و اما ساختار DLL
فایلهای DLL حاوی یک مدخل شروع انتخابی (optional entry point) و پایانی هستند که در زمانی که توسط برنامه‌های دیگر به درون حافظه لود یا آنلود می‌شوند قابل اجرا است. ویندوز این پروسه را در زمانی که یک برنامه DLLها را بدرون حافظه لود یا آنلود می‌کند اجرا می‌کند.
این دو نوع پروسه به DLL این امکان را می‌دهد که یک سری از مقدمات را پیش از استفاده مهیا کند یا بعد از استفاده پاکسازی نماید. در ویژال بیسیک این تابع بدین گونه تعریف می‌شود:


Public Function DllMain(hinstDLL As Long, fdwReason As Long , lpwReserved As Long) As Boolean

که پارامترهای آن بدین قرارند:
hInstDLL که حاوی یک مقدار یکتا بعنوان دستگیره فایل DLL است.
fdwReason مشخص کننده دلیل فراخوانی این پروسه توسط سیستم‌عامل است که یکی از چهار مقدار زیر را به خود منتصب می‌کند:
DLL_PROCESS_ATTACH (1): یک پروسه در حال لود DLL به دورن حافظه است. هر پیش‌نیاز باید در اینجا شکل گیرد.
DLL_THREAD_ATTACH (2): یک ریسمان (Thread) برای این DLL در حال تولید است. هر پیش‌نیاز برای ایجاد ریسمان در این مرحله می‌تواند شکل بگیرد.
DLL_THREAD_DETACH (3) ریسمان در حال پایان یافتن است. به منظور پاک‌سازی DLL از حافظه.
DLL_PROCESS_DETACH (0) فایل DLL در حال خروح از حافظه است. بمنظور پاک‌سازی سایر کارها توسط برنامه‌نویس امکان انجام در این مرحله فراهم آمده است.

lpvReserved: حاوی مقدار اضافی در استفاده از DLL_PROCESS_ATTACH یا DLL_PROCESS_DETACH می‌باشد.
مقدار برگشتی تابع DllMain در هنگام صدا زدن بصورت DLL_PROCESS_ATTACH مقدار TRUE را باید به خود بگیرد.

در تلاش برای تولید و توسعه یک DLL نمونه قصد این را داریم که یک کتابخانه ریاضی تشکیل دهیم. کد زیر در ماژولی بنام MathLib.Bas قرار می‌گیرد:


Option Explicit
Public Const DLL_PROCESS_DETACH = 0
Public Const DLL_PROCESS_ATTACH = 1
Public Const DLL_THREAD_ATTACH = 2
Public Const DLL_THREAD_DETACH = 3


Public Function DllMain(hInst As Long, fdwReason As Long, lpvReserved As Long) As Boolean
Select Case fdwReason
Case DLL_PROCESS_DETACH
' No per-process cleanup needed
Case DLL_PROCESS_ATTACH
DllMain = True
Case DLL_THREAD_ATTACH
' No per-thread initialization needed
Case DLL_THREAD_DETACH
' No per-thread cleanup needed
End Select
End Function


Public Function Increment(var As Integer) As Integer
If Not IsNumeric(var) Then Err.Raise 5

Increment = var + 1
End Function


Public Function Decrement(var As Integer) As Integer
If Not IsNumeric(var) Then Err.Raise 5

Decrement = var - 1
End Function


Public Function Square(var As Long) As Long
If Not IsNumeric(var) Then Err.Raise 5

Square = var ^ 2
End Function

به درخواست یکی از دوستان انجمن

[parsiyan_mohsen]

به نظر شما از چه دستوری استفاده کنیم که يک کلمه را توی يک فيلد بانک اطلاعاتي جستجو کنم نه اينکه اون کلمه اول نوشته باشه . اين کلمه ممکنه وسط هم نوشته شده باشه :
برای کاری که می خوای انجام بدی باید از دستورات SQL استفاده کنی.

اگر از کامپونت ADO استفاده می کنی دستور جستجوش به این شرحه :


Ado1.RecordSource= "Select * From [your table] Where [your field] Like ('%متن مورد نظر برای جستجو%')"

ولی اگر از کامپونت Data استفاده می کنی دستورش اینطوری می شه :


Data1.RecordSource= "Select * From [your table] Where [your field] Like ('*متن مورد نظر برای جستجو*')"

مثال : مثلا من یک Table با نام Table1 و یک فیلد به نام Address دارم و می خوام تمام آدرسهایی که توشون ( شیراز) داره پیدا کنم ، حالا این کلمه می خواد هرجایی از فیلد باشه :


Ado1.CommandType = adCmdText

Ado1.RecordSource= "Select * From Table1 Where Address Like ('%شیراز%')"

Ado1.Refresh

این آموزش واقعاً کاربردیه

[parsiyan_mohsen]

چیزی که از دستم بر میومد. امیدوارم خوشتون اومده باشه.

موفق باشید.

[jetclick]

سلام خسته نباشین
وافعا مطالبتون مفیده.ففط اگه میشه یکم توضیح بدین
میشه یکم دیگه راجب شماره گیری با مودم بگین
ممنون