مكتبة اجمل الاكواد واروعها حصريا على ارض الابداع والتميز برامج نت ( متجددة يوميا ) .

[hamata00]

http://www.9o9i.com/uploads/5f64be0b4c.gif

اود ان اقدم لكم اكبر مجموعه من الاكواد ستكون متجدده يوميا (ارجو التثبيت)
ارجو من المشرف انا ضفت 3 اكواد للتجربه لو ثبت الموضوع ساكمل الاكواد
الكود المهم ساكتب عليه متميز
1.اولا:اكواد عامه:0
--------------

1.كود لمعرفة الرقم التسلسلي للقرص الصلب:0(متميز)

'استخدام المكتبة
Microsoft ******ing Runtime
Private Sub Command1_Click()
Dim obj_FSO As Object, obj_Drive As Object
Set obj_FSO = CreateObject("******ing.FileSystemObject")
Set obj_Drive = obj_FSO.GetDrive("c:\")
MsgBox obj_Drive.SerialNumber
Set obj_FSO = Nothing
Set obj_Drive = NothingEnd Sub

http://www.9o9i.com/uploads/9cbd215e2b.gif

2.فتح cd -romواغلاقه
'ضع هذا الكود في الفورم

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 OpenCDDriveDoor(ByVal State As Boolean)
If State = True Then
Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
Else
Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
End If
End Sub
في كوماند واحد

Private Sub Command1_Click()
OpenCDDriveDoor (True)
End Sub

وفي كوماند 2

Private Sub Command2_Click()
OpenCDDriveDoor (False)
End Sub

http://www.9o9i.com/uploads/9cbd215e2b.gif

3.رسم دوائر ملونه باستخدام الماوس:0
ضع هذا الكود في الفورم
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
i = Rnd * 15
If Button = 1 Then
Me.Circle (X, Y), 200, QBColor(i)
End If
End Sub

وفي زر كوماند واحد

Private Sub Command1_Click()
Form1.Cls
End Sub

http://www.9o9i.com/uploads/9cbd215e2b.gif

4.كود لعمل شورت كات للبرنامج:0(متميز)
Set wshshell = CreateObject("W******.shell")
nStr = wshshell.specialfolders("Desktop")
'(هذا بالنسبة للمكتب)
set oshelllink = wshshell.createShortcut("nStr & "\MYPROGGR.lnk")
oshelllink.Targetpath="c.....\prog.exe"
oshelllink.hotkey = "ctrl+alt+c"
oshelllink.iconlocation="c.....\pro.ico"
oshelllink.de******ion="........"
oshelllink.save
اسبدل فقط desktop ب Startup لتجعل برنامجك في البداية او
Start Menu
او Programs

http://www.9o9i.com/uploads/9cbd215e2b.gif

5.تشغيل حافظة الشاشة screen saver:(متميز)

ضع الكود التالي في الفورم

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, ByVal lParam As Long) As Long

والتالي في كوماند 1

Private Sub Command1_Click()
Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0)
End Sub

http://www.9o9i.com/uploads/9cbd215e2b.gif

6.كود لفتح صورة معينه:0
ضع الكود التالي في الفورم
Picture1.Picture = LoadPicture("اكتب مسار الصوره .الامتداد")

http://www.9o9i.com/uploads/9cbd215e2b.gif

7.طباعة نص:0ضع الكود التالي في الفورمPrivate Sub Command1_Click()
Printer.Print text1.text
End Sub

http://www.9o9i.com/uploads/9cbd215e2b.gif

ثانيا:اكواد الحمايه:0
----------------

1.منع تشغيل البرنامج اكثر من مرة:0(متميز)
ضع هذا الكود في الفورم

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

http://www.9o9i.com/uploads/9cbd215e2b.gif

2.فورم MDI + PictureBox
Private Sub MDIForm_Load()
Picture1.Picture = LoadPicture("مكان الملف.الامتداد")
End Sub

Private Sub MDIForm_Resize()
Picture1.Move 0, 0, Me.Width, Me.Height
End Sub

3.حصر الماوس داخل نطاق معين:0

ضع الكود التالي في الفورم

Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Private Type POINT
X As Long
Y As Long
End Type


Private Sub Command1_Click()
Dim Client As RECT
Dim Up As POINT
ClientToScreen Me.hwnd, Up
GetClientRect Me.hwnd, Client
OffsetRect Client, Up.X, Up.Y
Up.X = Client.Left
Up.Y = Client.Top
ClipCursor Client
End Sub


Private Sub Command2_Click()
ClipCursor ByVal 0&
End Sub


4.جعل ال TextBox لا يقبل الا ارقام عشرية


هذا الكود يجعل ال TextBox لا يقبل الا أرقام عشرية و يتم و ضعه في الحدث KeyPress



if(Char.IsNumber(e.KeyChar) || e.KeyChar = = (char)8 || (e.KeyChar = = ' . ' & ((TextBox)sender).Text.IndexOf( ' . ' ) < 0))
{
e.Handled = false;
}
else e.Handled = true;



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

اكواد :ahmed ksnv
.لمعرفة حجم مجلد معين:0

Private 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 FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long

'Insert the following code to your form:

Private Function SizeOf(ByVal DirPath As String) As Double
Dim hFind As Long
Dim fdata As WIN32_FIND_DATA
Dim dblSize As Double
Dim sName As String
Dim x As Long
On Error Resume Next
x = GetAttr(DirPath)
If Err Then SizeOf = 0: Exit Function
If (x And vbDirectory) = vbDirectory Then
dblSize = 0
Err.Clear
sName = Dir$(EndSlash(DirPath) & "*.*", vbSystem Or vbHidden Or vbDirectory)
If Err.Number = 0 Then
hFind = FindFirstFile(EndSlash(DirPath) & "*.*", fdata)
If hFind = 0 Then Exit Function
Do
If (fdata.dwFileAttributes And vbDirectory) = vbDirectory Then
sName = Left$(fdata.cFileName, InStr(fdata.cFileName, vbNullChar) - 1)
If sName <> "." And sName <> ".." Then
dblSize = dblSize + SizeOf(EndSlash(DirPath) & sName)
End If
Else
dblSize = dblSize + fdata.nFileSizeHigh * 65536 + fdata.nFileSizeLow
End If
DoEvents
Loop While FindNextFile(hFind, fdata) <> 0
hFind = FindClose(hFind)
End If
Else
On Error Resume Next
dblSize = FileLen(DirPath)
End If
SizeOf = dblSize
End Function

Private Function EndSlash(ByVal PathIn As String) As String
If Right$(PathIn, 1) = "\" Then
EndSlash = PathIn
Else
EndSlash = PathIn & "\"
End If
End Function

Private Sub Form_Load()
'Replace 'c:\windows' with the directory name that you want to get its size.
MsgBox SizeOf("c:\windows")
End Sub

2.تحديد نوع نظام الملفات لأي قسم من القرص

Private Declare Function GetVolumeInformation Lib _
"kernel32.dll" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long

Private Function FileSystem(ByVal Drive As String) As String

Dim lAns As Long
Dim lRet As Long
Dim sVolumeName As String, sDriveType As String
Dim sDrive As String
Dim iPos As Integer

sDrive = Drive
If Len(sDrive) = 1 Then
sDrive = sDrive & ":\"
ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" Then
sDrive = sDrive & "\"
End If

sVolumeName = String$(255, Chr$(0))
sDriveType = String$(255, Chr$(0))

lRet = GetVolumeInformation(sDrive, sVolumeName, _
255, lAns, 0, 0, sDriveType, 255)
iPos = InStr(sDriveType, Chr$(0))
If iPos > 0 Then sDriveType = Left(sDriveType, iPos - 1)

FileSystem = sDriveType
End Function


Private Sub Form_Load()
MsgBox "The file system of drive c: is: " & FileSystem("c:")
End Sub


3.النسخ الاحتياطي للبيانات

Private Sub CMDmak_Click()

'MkDir "D:\BACKUP"
'MkDir "D:\BACKUP\SITRAWI"
End Sub
'لنسخ الملف

Private Sub CMDBAK_Click()
SOURCE = "D:\hus\Aig.bmp"
dESTN = "D:\BACKUP\SITRAWI\AIG.BMp"
FileCopy SOURCE, dESTN
End Sub






4.دالة MoveFile لنقل ملف

Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Command1_Click()
MoveFile "c:\my ********s\a.txt", "c:\a.txt"
End Sub

5.دوال التعامل مع الملفات

الدالة FileLen : تعود هذه الدالة بقيمه تمثل حجم الملف بالبايت وتأخذ الصورة التالية
code: ss = FileLen("c:\TafTaf.txt")
MsgBox ss & " Byte"

الدالة FileDateTime : وتعطي لك هذه الدالة معلومات عن وقت وتاريخ إنشاء الملف وتأخذ الصورة التالية :

code: ss = FileDateTime("c:\TafTaf.txt")
MsgBox ss

الدالة LOF : وهذه الدالة قريبة الشبه بالدالة FileLen ولكن الاختلاف بينهم أن هذه الدالة تعود بقيمه تمثل حجم الملفات المفتوحة بتمرير رقم للملف المفتوح وتأخذ الصورة التالية :

code: Open "C:\TafTaf.txt" For Binary As #1
MsgBox LOF(1) & " Byte"
Close 1

الدالة LOC : تعيد هذه الدالة موقع مؤشر القراءة والكتابة في الملف المفتوح وتأخذ الصورة التالية :

code: Dim ss
Open "c:\TafTaf.txt" For Input As #1
Loc (1)
Line Input #1, ss
MsgBox ss
Close #1

الدالة EOF : تعود هذه الدالة بقيمة منطقية تبين ما إذا قد تم الوصول لنهاية الملف أم لا (False - True ) وتأخذ الصورة التالية :

code: Dim ss
Open "c:\TafTaf.txt" For Input As #1
Do While Not EOF(1(
Line Input #1, ss
Text1.Text = Text1.Text & vbNewLine & ss
Loop
Close #1

الدالة GetAttr : : تمكنك هذه الدالة من معرفة خصائص الملف File Attributes وتأخذ الصورة التالية :

code: If GetAttr("c:\TafTaf.txt") = vbNormal Then
MsgBox "الملف غير مخفي"
Else
MsgBox "الملف مخفي"
End If


الدالة SetAttr : وهذه الدالة تمكنك من تغير خصائص الملفات شرط أساسي أن يكون الملف غير مفتوح وتأخذ الصورة التالية :

code: SetAttr ("c:\TafTaf.txt"), vbHidden


الدالة FreeFile : تعود هذه الدالة برقم غير محجوز ( رقم حر غير مستخدم ) لفتح الملف وتأخذ الصورة التالية :

code: MyFree = FreeFile
Open "c:\TafTaf.txt" For Input As #MyFree
MsgBox MyFree
Close #MyFree


الدالة Seek : تعمل هذه الدالة علي تغير موقع مؤشر القراءة والكتابة في الملف وتأخذ الصورة التالية :

code: Dim ss
Open "c:\TafTaf.txt" For Input As #1
Seek #1, 20
Line Input #1, ss
MsgBox ss
Close #1


الدالة SavePicture : تعمل هذه الدالة علي حفظ الصورة إلى ملف خارجي بأي امتداد تريده ومن أي أداة يمكنها احتواء صورة بداخلها وتأخذ الشكل التالي :

code: SavePicture Picture1.Picture, "C:\TafTaf.bmp"


الدالة LoadPicture : تعمل هذه الدالة علي ( تحميل ) الصورة من مكان تحدده أنت أو من الممكن ( تحميل ) الصورة تابعة لكائن وتأخذ الصورة التالية :

code: Picture1.Picture = LoadPicture("c:\TafTaf.bmp")


5.التأكد من وجود ملف


Private Sub Command1_Click()
On Error GoTo Error:
Open "ضع مسار الملف هنا" For Input As #1
Close
MsgBox ("الملف موجود")
Exit Sub
Error:
MsgBox ("الملف غير موجود")
End Sub

كود آخر

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



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



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



7.ارسال ملف الى سلة المحذوفات


Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As Long
End Type

Private Declare Function SHFileOperation Lib _
"shell32.dll" Alias "SHFileOperationA" (lpFileOp _
As SHFILEOPSTRUCT) As Long

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40


Private Sub Command1_Click()
Dim SHop As SHFILEOPSTRUCT
Dim strFile As String

strFile = "C:\autoexec.bat"

With SHop
.wFunc = FO_DELETE
.pFrom = strFile
.fFlags = FOF_ALLOWUNDO
End With

SHFileOperation SHop

End Sub




البرنامج برعايه:01.hamata00
2.ahmed ksnv

[zakimoulayabdellah]

gooood hamata

[veto_44]

تامر امر عزيزي يثبت الموضوع وننتظر منك اضافة الاكواد يومـــيـا
وخصوصا الاكواد المميزة التي عودتنا عليها بارك الله فيك وباخــونا
احمد على المبادرة الطيبة وتلبيتكم لاختراحي وننتظر منكم موضوع
مميز مليئ بالمعلومات الشيقة دمتم برعاية الله وحفظه .

[(li) صقر (li)]

ننتظر البقية أخي العزيز
شكراً موسوعة حلوة من واحد زيها

[SuPeR.HuMaN]

مشكور أخى وبارك لله فيك على هذه الأكواد

[alae001]

بارك الله فيكما والله موضوع جميل وونتظر منك الجديد أخي.

[ahmed ksnv]

http://img77.imageshack.us/img77/6472/t199ko9.gif



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

مع ملاحظة أني لم أقم بكتابة أي كود ( وإنما نقلت الأكواد كما هي مع بعض التغييرات البسيطة )

لكي تعم الفائدة ( ولتقليل الأسألة المتكررة )

بسم الله نبدأ :

1 : فتح صفحة إنترنت من داخل برنامجك

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Sub Label1_Click()
Dim lapi As Long
a$ = App.Path & "index.html"
lapi = ShellExecute(Me.hwnd, "open", a$, vbNull, vbNull, 5)
End Sub

الطريقة الثانية

Shell ("explorer http://www.bramjnet.com"), vbNormalNoFocus

http://img352.imageshack.us/img352/39/f092ub5.gif
2 : تنفيذ الكود بعد فترة زمنية

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

Private Sub cmd_Click()
MsgBox Time
Sleep 10000
MsgBox Time
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
3 : فتح وغلق السي دي

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

Private Sub فتح_Click()
Call mciSendString("Set CDAudio Door Open", "", 0, 0)
End Sub

Private Sub غلق_Click()
Call mciSendString("Set CDAudio Door Closed", "", 0, 0)
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
4 : تغيير خلفية الجهاز

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
Public Const SPI_SETDESKWALLPAPER = 20
Private Sub Command1_Click()
Dim lngSuccess As Long
Dim strBitmapImage As String

strBitmapImage = "c:windowsstraw.bmp"
lngSuccess = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, strBitmapImage, 0)

End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
5 : تشغيل ملف صوتي

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

Private Sub Command1_Click ()
sndPlaySond "c:\MySound.wav" , 1
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
6 : تحريك الفورم بمفاتيح الأسهم في لوحة المفاتيح

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal v As Long) As Integer

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If GetAsyncKeyState(37) Then 'يسار
Left = Left - 15
End If

If GetAsyncKeyState(38) Then 'أعلى
Top = Top - 15
End If

If GetAsyncKeyState(39) Then 'يمين
Left = Left + 15
End If

If GetAsyncKeyState(40) Then 'أسفل
Top = Top + 15
End If
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
7 : رسم مؤشر الماوس على الفورم

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function GetCursor Lib "user32" () As Long
Private Sub Form_Paint()
DrawIcon Me.hdc, 30, 30, GetCursor
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
8 : إضافة أيقونة البرنامج في شريط المهام

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _
Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) As Longprivate
Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const NIM_ADD = &H0
Private Const NIM_DELETE = &H2
Private Const NIM_MODIFY = &H1
Private Const NIF_ICON = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_TIP = &H4
Private Ic As NOTIFYICONDATA 'هنا تعريف المتغير من نوع NotifyIcon
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''
Private Sub Load_Form()
Ic.cbSize = Len(Ic)
Ic.hwnd = Me.hwnd 'مقبض النافذة
Ic.uID = 1&
Ic.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE 'يحتوي على : ايقون + ملاحظات + رسائل الفأرة
Ic.uCallbackMessage = WM_RBUTTONDOWN Or WM_RBUTTONUP Or WM_RBUTTONDBLCLK 'رسائل الفأرة النشطة
Ic.hIcon = Picture 'ضع هنا الايقونه
Ic.szTip = "My Program First" 'الملاجظات الخاصة للبرنامج او ما يسمىToolTipText
Shell_NotifyIcon NIM_ADD, Ic 'الأمر اضافة للأيقونة
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''
Private Sub Form_Unload()
Ic.cbSize = Len(Ic)
Ic.hwnd = Me.hwnd
Ic.uID = 1&
Shell_NotifyIcon NIM_DELETE, Ic 'الأمر حذف للأيقونة
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''
Private Sub Timer1_Timer()
Ic.szTip = "My Program Second"
Shell_NotifyIcon NIM_MODIFY, Ic 'الأمر تعديل في الأيقونة وهنا كان التعديل فقط على الملاحظات
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
9 : تجميد برنامج وإعادة تنشيطة

Private Declare Function CreateProcessBynum Lib "kernel32" _
Alias "CreateProcessA" (ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, ByVal lpProcessAttributes As _
Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles _
As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, _
ByVal lpCurrentDirectory As String, lpStartupInfo As _
STARTUPINFO, lpProcesstInfrmation As PROCESS_INFORMATION) As Long

Private Declare Function SuspendThread Lib "kernel32" _
(ByVal hThread As Long) As Long

Private Declare Function ResumeThread Lib "kernel32" _
(ByVal hThread As Long) As Long

'PROCESS_INFORMATION و STARTUPINFO البنيتين
' Process التي نحتاجها لانشاء الـ
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type

Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Const NORMAL_PRIORITY_CLASS = &H20

Dim Ret&, PrInf As PROCESS_INFORMATION
Dim stInf As STARTUPINFO

Private Sub Command1_Click()
'من الافضل ضبطها
With stInf
.cb = Len(stInf)
.lpReserved = vbNullString
.lpDesktop = vbNullString
.lpTitle = vbNullString
.dwFlags = 0
End With
'Process انشاء الـ
Ret = CreateProcessBynum("C:\Windows\calc.exe", vbNullString, 0, 0, _
True, NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, stInf, PrInf)
End Sub

Private Sub Command2_Click()
'Thread تجميد الـ
SuspendThread PrInf.hThread
End Sub

Private Sub Command3_Click()
'Thread اعادة تنشيط الـ
ResumeThread PrInf.hThread
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
10 : جعل البرنامج يعمل مع بدء تشغيل وندوز

Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Sub Form_Load()
Dim lRegKey As Long
Dim sApp As String
sApp = App.Path + IIf(Right(App.Path, 1) <> "\", "\", "") + App.EXEName + ".exe"
If RegOpenKey(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run\", lRegKey) = 0 Then
If RegSetValueEx(lRegKey, "My Program", 0, 1, ByVal sApp, Len(sApp)) Then
MsgBox "There was a Problem Adding This Program to the Registry", vbExclamation, "Error"
End If
Call RegCloseKey(lRegKey)
End If
End Sub


الطريقة الثانية

Set iii= CreateObject("w******.shell")
'للكتابة
iii.regwrite " HKEY_CURRENT_USER\Software\Microsoft\Windows\Curre
ntVersion\Run\code4arab", "c:\file name"
'اما للقراءه
iii.regread " HKEY_CURRENT_USER\Software\Microsoft\Windows\Curre
ntVersion\Run\code4arab", "c:\file name"

http://img352.imageshack.us/img352/39/f092ub5.gif
11 : كود لقلب الشاشة عموديا

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal _
x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop _
As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x _
As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal _
nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Sub Form_Initialize()
Dim W, H
W = Screen.Width / 15
H = Screen.Height / 15
StretchBlt hdc, 0, H, W, -H, GetDC(0&), 0, 0, W, H, vbSrcCopy

End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, _
y As Single)
End
End Sub

ملاحظة قلب الشاشة معناة إلتقاط صورة لسطح المكتب ثم قلب الصورة ولصقها في الفورم مع تكبير الفورم لحجم الشاشة

http://img352.imageshack.us/img352/39/f092ub5.gif
12 : فتح ملف نصي ووضعة في أداة نص

Open "c:\windows\desktop\books.txt" For Input As #1
Text1.Text = Input(LOF(1), 1)
Close #1

http://img352.imageshack.us/img352/39/f092ub5.gif
13 : إخفاء وإظهار مؤشر الفأرة

Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long
اخفاء المؤشر
x = ShowCursor(False)
إظهار المؤشر
x = ShowCursor(True)

http://img352.imageshack.us/img352/39/f092ub5.gif
14 : إطفاء الشاشة وتشغيلها

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
Const WM_SYSCOMMAND = &H112
Const SC_MONITORPOWER = &HF170

' لإطفاء الشاشة
SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, 2&
'لتشغيل الشاشة
SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, -1&

http://img352.imageshack.us/img352/39/f092ub5.gif
15 : معرفة العنصر الذي تحت مؤشر الماوس في القائمة

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 Const LB_ITEMFROMPOINT = &H1A9
Private Sub List1_MouseMove(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
Dim P As Long
Dim XPosition As Long, YPosition As Long
XPosition = CLng(X / Screen.TwipsPerPixelX)
YPosition = CLng(Y / Screen.TwipsPerPixelY)

P = SendMessage(List1.hWnd, LB_ITEMFROMPOINT, 0, ByVal _
((YPosition * 65536) + XPosition))
If P < List1.ListCount Then
List1.ToolTipText = List1.List(P)
End If
End Sub

[الفرعون المحترف]

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

[ahmed ksnv]

http://img77.imageshack.us/img77/6472/t199ko9.gif
16: إفراغ سلة المحذوفات

Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long

Private Sub Form_Load()
'الإفراغ
SHEmptyRecycleBin Me.hwnd, vbNullString, 0
'التحديث
SHUpdateRecycleBinIcon
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
17 : جلب معلومات البويس

Option Explicit
Private Declare Sub GetMem1 Lib "msvbvm50.dll" (ByVal _
MemAddress As Long, var As Byte)
Private Function GetBIOSDate() As String
Dim p As Byte, MemAddr As Long, sBios As String
Dim i As Integer
MemAddr = &HFE000
For i = 0 To 331
Call GetMem1(MemAddr + i, p)
If p > 31 And p <= 128 Then
sBios = sBios & Chr$(p)
End If
Next i
GetBIOSDate = sBios
End Function

Private Sub Form_Load()
Text1.Text = GetBIOSDate
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
18 : رسم دائرة صغيرة حول مؤشر الماوس تتبع حركتة

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.Cls
Circle (X, Y), 100, vbRed
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

http://img352.imageshack.us/img352/39/f092ub5.gif
19 : إغلاق أي برنامج بمعرفة عنوان النافذة

AppActivate "عنوان النافذة التي تريد إغلاقها"
SendKeys "%{F4}"

http://img352.imageshack.us/img352/39/f092ub5.gif
20 : إغلاق الفورم بشكل تدرجي

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
DoEvents
frmSlide.Left = frmSlide.Left + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 250)
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
21 : هل تريد إخفاء برنامجك من قائمة Ctrl+Alt+Del

Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" _
(ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Sub HideApp(Hide As Boolean)
Dim ProcessID As Long
ProcessID = GetCurrentProcessId()
If Hide Then
retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
Else
retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
End If
End Sub
Private Sub Form_Load()
HideApp (True)
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
22 : خلفية متدرجة باللون الأزرق مثل برامج الإعداد

Sub Fade(vForm As Form)
Dim intLoop As Integer
vForm.DrawStyle = vbInsideSolid
vForm.DrawMode = vbCopyPen
vForm.ScaleMode = vbPixels
vForm.DrawWidth = 2
vForm.ScaleHeight = 256
For intLoop = 0 To 255
'خلفية متدرجة باللون الازرق
vForm.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(0, 0, 255 - intLoop), B
Next intLoop
End Sub
Private Sub Form_Activate()
Fade Me
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
23 : هل تريد منع المستخدم من استخدام المسافة في صندوق النص

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 32 Then
KeyAscii = 0
End If
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
24 : لتوسيط الفورم وسط الشاشة استخدم الإجراء التالي

Sub CenterForm(Frm As Form)
Frm.Move (Screen.Width - Frm.Width) / 2, (Screen.Height - Frm.Height) / 2
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
25 : تشغيل حافظة الشاشة

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, ByVal lParam As Long) As Long
'لبدء تشغيل حافظة شاشة الويندوز
Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0)

http://img352.imageshack.us/img352/39/f092ub5.gif
26 : لتحديد دقة عرض الشاشة

Private Sub Command1_Click()
Dim intWidth As Integer
Dim intHeight As Integer
intWidth = Screen.Width \ Screen.TwipsPerPixelX
intHeight = Screen.Height \ Screen.TwipsPerPixelY
MsgBox "Screen Resolution:" + Str$(intWidth) + " x" + Str$(intHeight)
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
27 : فتح برنامج محرر النصوص وكتابة جملة

Private Sub Command1_Click()
Shell "notepad.exe", vbNormalNoFocus
AppActivate ("Untitled - Notepad")
SendKeys ("أهلا بكم في منتديات الفريق العربي للبرمجة")
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
28 : التراجع عن الإجراء الأخير في مربع نص

Private Declare Function SendMessageBynum& Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg _
As Long, ByVal wParam As Long, ByVal lparam As Long)
Private Const EM_UNDO = &HC7&
Private Sub TextUndo(T As TextBox)
SendMessageBynum T.hwnd, EM_UNDO, 0, 0
End Sub
Private Sub Command1_Click()
Call TextUndo(Text1)
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
29 : تغيير صفحة البدء لمتصفح الإنترنت

Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" _
Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
Private Const REG_SZ = 1
Private Const HKEY_CURRENT_USER = &H80000001
Public Sub SaveString(hKey As Long, Path As String, _
Name As String, Data As String)
Dim KeyHandle As Long
Dim r As Long
r = RegCreateKey(hKey, Path, KeyHandle)
r = RegSetValueEx(KeyHandle, Name, 0, _
REG_SZ, ByVal Data, Len(Data))
r = RegCloseKey(KeyHandle)
End Sub
Public Sub SetStartPage(URL As String)
Call SaveString(HKEY_CURRENT_USER, _
"Software\Microsoft\Internet Explorer\Main", _
"Start Page", URL)
End Sub
Private Sub Command1_Click()
SetStartPage ("http://arabteam.nicmatic.com")
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
30 : معرفة عدد الكلمات في النص

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

وتستخدم
lLineCount = GetWordCount(Text1.Text)

31 : عرض فورم داخل فورم
أضف نموذجين Form1 , Form2

Private Declare Function SetParent Lib "user32" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
SetParent Form1.hwnd, Form2.hwnd
Form2.Show
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
32 : طريقة الضغط على زر الامر برمجيا بطريقة مرئية
أضف command1 - Timer1 - Timer2

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 Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Sub Form_Load()
Timer1.Interval = 1000
Timer2.Interval = 1000
Timer1.Enabled = True
Timer2.Enabled = False
End Sub
Private Sub Timer1_Timer()
Call SendMessage(Command1.hwnd, WM_LBUTTONDOWN, 0, ByVal 0)
Timer1.Enabled = False
Timer2.Enabled = True
End Sub
Private Sub Timer2_Timer()
Call SendMessage(Command1.hwnd, WM_LBUTTONUP, 0, ByVal 0)
Timer2.Enabled = False
Timer1.Enabled = True
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
33 : أيضا بإمكانك تحريك الماوس برمجيا باستخدام الكود التالي
أضف 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

[ahmed ksnv]

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

مشكور
الوداع قرب
الوداع قرب
الوداع قرب
الوداع قرب
الوداع قرب
الوداع قرب
الوداع قرب

[hamata00]

شكراا علي الموضوع المميز من عضو مميز

[ahmed ksnv]

http://img77.imageshack.us/img77/6472/t199ko9.gif
34 : النسخ من و الى الحافظه

من التكست
Clipboard.Clear
Clipboard.SetText txtBox.Text, vbCFText

الى التكست
txtBox.SelText = Clipboard.GetText
txtBox.Text = Clipboard.GetText

http://img352.imageshack.us/img352/39/f092ub5.gif
35 : تغيير الكتابة من العربي إلى الإنجليزي وبالعكس
أضف زر أمر وأضف أداة نص

Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long

Private Sub Command1_Click()
ActivateKeyboardLayout hkl_next, klf_reorder
End Sub
كل ضغطة على زر الأمر تغير اللغة

http://img352.imageshack.us/img352/39/f092ub5.gif
36 : معرفة وتغيير ألوان واجهة وندوز

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

http://img352.imageshack.us/img352/39/f092ub5.gif
37 : عرض نافذة تهيئة الأقراص -فورمات

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

http://img352.imageshack.us/img352/39/f092ub5.gif
38 : إنشاء قائمة وعرضها عند الضغط بالزر الأيمن للماوس على الفورم

Private Const SCOFFSET = 2000&
Private Const MF_STRING = &H0

' تستطيع استبدال الثابت TPM_RIGHTALIGN
'بأي من الثوابت ادناه
Private Const TPM_CENTERALIGN = &H4
Private Const TPM_TOPALIGN = &H0&
Private Const TPM_BOTTOMALIGN = &H20&
Private Const TPM_RIGHTALIGN = &H8
Private Const TPM_LEFTALIGN = &H0
Private Const TPM_VCENTERALIGN = &H10&
Private Const TPM_VERTICAL = &H40&
Private Const TPM_HORIZONTAL = &H0&

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
Private Declare Function TrackPopupMenuBylong Lib _
"user32" Alias "TrackPopupMenu" (ByVal hMenu _
As Long, ByVal wFlags As Long, ByVal X As _
Long, ByVal Y As Long, ByVal nReserved As _
Long, ByVal hwnd As Long, ByVal lprc As _
Long) As Long
Private Declare Function AppendMenu Lib "user32" _
Alias "AppendMenuA" (ByVal hMenu As Long, ByVal _
wFlags As Long, ByVal wIDNewItem As Long, ByVal _
lpNewItem As Any) As Long
Private Declare Function CreatePopupMenu Lib "user32" _
() As Long

'مقبض للقائمة الجديدة
Dim hMnue&

Private Sub Form_Load()
Dim ID&, I As Byte
'انشاء قائمة منبثقة
hMnue = CreatePopupMenu()
'اضافة العناصر إلى القائمة
For I = 1 To 4
AppendMenu hMnue, MF_STRING, _
SCOFFSET + ID, "item " & I
ID = ID + 1
Next I
End Sub

Private Sub Form_MouseDown(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
Dim pt As POINTAPI
If Button = 2 Then
'الحصول على احداثيات الفأرة
GetCursorPos pt
'اظهار القائمة
TrackPopupMenuBylong hMnue, TPM_RIGHTALIGN, _
pt.X, pt.Y, 0, hwnd, 0&
End If
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
39 : معرفة حالة الإتصال بالإنترنت والمدة الزمنية

Private Declare Function InternetGetConnectedState Lib _
"wininet.dll" (ByRef dwFlags As Long, _
ByVal dwReserved As Long) As Long
Dim flags As Long
Dim status As Boolean
Dim startTime As Long, endTime As Long
Dim dummy As Boolean
Const INTERNET_CONNECTION_CONFIGURED As Long = &H40

Private Sub Timer1_Timer()
If InternetGetConnectedState(flags, 0) = 1 Then
'التأكد من وضعيه الاتصال
If flags And INTERNET_CONNECTION_CONFIGURED Then
status = True 'متصل
Else
status = False 'غير متصل
End If
Else
status = False
End If

If status = True And dummy = False Then
dummy = True
startTime = Timer 'عدد الثواني منذ منتصف الليل
End If
If status = False And dummy = True Then
dummy = False
endTime = Timer
Label1 = (endTime - startTime) / 60 'عدد الدقائق المستغرقه
End If
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
40 : حذف الرموز الغير مرغوب بها من جملة نصية

Public Function Clean(sString As String) As String
Dim nLength As Integer
Dim nStart As Integer
Dim sOne As String
Dim sNoWay As String '
sNoWay = " ',-.()!_$*<>/\?;:=+" ' الحروف المراد حذفها
If Not IsNull(sString) Then
nLength = Len(sString)
nStart = 1
Do While nStart <= nLength
sOne = Mid(sString, nStart, 1)
If InStr(1, sNoWay, sOne, vbTextCompare) = 0 Then
Clean = Clean & sOne
End If
nStart = nStart + 1
Loop
End If
End Function
Private Sub Command1_Click()
MsgBox Clean("منتديات-الفريق'العربي=للبرمجة")
End Sub

http://img352.imageshack.us/img352/39/f092ub5.gif
41 : لإيقاف تشغيل الويندوز بدون APIs

WinDir$ = Environ$("windir")
KillWin$ = WinDir$ + "\Rundll.exe User.exe,ExitWindows"
Shell KillWin$

http://img352.imageshack.us/img352/39/f092ub5.gif
42 : لمعرفة حجم ملف

lFileSize = FileLen(strFileName)
اذا تبغى الحجم بالكيلو بايت اقسم على 1024

http://img352.imageshack.us/img352/39/f092ub5.gif
43 : لعرض جميع الطابعات بدون APIs

Dim cPrinter As Printer
For Each cPrinter In Printers
Print Printer.DeviceName
Next

http://img352.imageshack.us/img352/39/f092ub5.gif
44 : عدم تشغيل اكثر من نسخه من برنامجك

If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل اثر من نسخه في نفس الوقت"
UnLoad Me
Exit Sub
End If

http://img352.imageshack.us/img352/39/f092ub5.gif
45 : معرفة مسار مجلد الوندوز

Dim winPath As String
winPath = Environ$("windir")

http://img352.imageshack.us/img352/39/f092ub5.gif
46 : إبطال مفعول زر إكس في النافذة

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

http://img352.imageshack.us/img352/39/f092ub5.gif
47 : حذف جميع الملفات داخل مجلد

Kill "c:\windows\desktop\vb\*.*"


48 : تشغيل برنامج معين

shell "C:\WINDOWS\CALC.EXE

http://img352.imageshack.us/img352/39/f092ub5.gif
49 : إقاف عمل الماوس والكيبورد

shell "rundll32.exe keyboard,disable", vbNormalFocus
shell "rundll32.exe mouse,disable", vbNormalFocus
مع ملاحظة أنك لن تستطيع عمل أي شيء إلى غلق الجهاز

http://img352.imageshack.us/img352/39/f092ub5.gif
50 : تستطيع بناء أداة ToolTipText خاصة بك لإظهار النص في أي وقت وأي مكان.

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type

Private Const WS_POPUP = &H80000000
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOPMOST = -1
Private Const DT_LEFT = &H0
Private Const DT_CALCRECT = &H400
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
ByVal lpClassName As String, ByVal lpWindowName _
As String, ByVal dwStyle As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight _
As Long, ByVal hWndParent As Long, ByVal hMenu As _
Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal _
hwnd As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal _
hhDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal _
hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crctolor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal _
hhDC As Long, lpRect As RECT, ByVal hBrush As Long) _
As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal _
hhDC As Long, ByVal crctolor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias _
"DrawTextA" (ByVal hhDC As Long, ByVal lpStr As _
String, ByVal nCount As Long, lpRect As RECT, _
ByVal wFormat As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal _
hhDC As Long, Rct As RECT, ByVal edge As Long, ByVal _
grfFlags As Long) As Boolean

Private lng_hWnd As Long

Sub GetToolTipText(txt As String)
Dim hDC&, hBrush&, ClrInfo&
Dim pt As POINTAPI, Rct As RECT

ClrInfo = &HE1FFFF
If Not lng_hWnd Then
'انشاء أداة عنوان
lng_hWnd = CreateWindowEx(0, "STATIC", "", WS_POPUP, _
0, 0, 0, 0, hwnd, 0, App.hInstance, 0)
End If

'(الحصول على مقبض سياق الجهاز (منطقة الرسم
hDC = GetDC(lng_hWnd)
SetBkColor hDC, ClrInfo
'الحصول على أبعاد النص
DrawText hDC, txt, Len(txt), Rct, DT_CALCRECT
' الهوامش
Rct.Bottom = Rct.Bottom + 6
Rct.Right = Rct.Right + 6
GetCursorPos pt

'اظهار أداة العنوان في موقع المشيرة
SetWindowPos lng_hWnd, HWND_TOPMOST, pt.X - 5, pt.Y + 20, _
Rct.Right - Rct.Left, Rct.Bottom - Rct.Top, _
SWP_SHOWWINDOW Or SWP_NOACTIVATE
DoEvents

'الحصول على مقبض الفرشاه للتلوين
hBrush = CreateSolidBrush(ClrInfo)
FillRect hDC, Rct, hBrush
DeleteObject hBrush
'رسم الحواف البارزة
DrawEdge hDC, Rct, 1, BF_LEFT Or BF_RIGHT
DrawEdge hDC, Rct, 1, BF_TOP Or BF_BOTTOM
With Rct
.Left = .Left + 3: .Right = .Right - 3
.Top = .Top + 3: .Bottom = .Bottom - 3
End With
'رسم النص
DrawText hDC, txt, Len(txt), Rct, DT_LEFT
End Sub

Private Sub Form_Load()
Timer1.Interval = 50
End Sub

Private Sub Timer1_Timer()
If lng_hWnd Then
DestroyWindow lng_hWnd
End If
GetToolTipText "vb4arab"
End Sub

[ahmed ksnv]

مشكور
الوداع قرب

[hamata00]

شكررررررررا جدا

[ahmed ksnv]

http://img77.imageshack.us/img77/6472/t199ko9.gif

+ للأتصال بالأنترنت باستخدام الــ 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

http://img352.imageshack.us/img352/39/f092ub5.gif

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

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

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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(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

http://img352.imageshack.us/img352/39/f092ub5.gif
+ كود تستطيع من خلاله حذف اي ملف

قم بوضع هذا الكود في قسم جنرال
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")

http://img352.imageshack.us/img352/39/f092ub5.gif

+ عمل مسح ملفات للقرص المرن

kill"A:\*.*"

http://img352.imageshack.us/img352/39/f092ub5.gif

+ عرض صندوق حوار Open With

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

http://img352.imageshack.us/img352/39/f092ub5.gif

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

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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ فحص المنافذ

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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ لإنهاء صلاحيات برنامجك التجريبي بعد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

http://img352.imageshack.us/img352/39/f092ub5.gif

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

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

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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ فورم دائري

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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ كلام متحرك في 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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ فتح وغلق سواقة الأقراص

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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ امر بحث عن الملفات

'ضع هذا الكود في ملف باس 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

http://img352.imageshack.us/img352/39/f092ub5.gif

+ 'البحث عن ملف

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

[ahmed ksnv]

شكررررررررا جدا

مشكور
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع

[ahmed ksnv]

بارك الله فيكما والله موضوع جميل وونتظر منك الجديد أخي.

له لوحده .

[الفرعون المحترف]

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

[ahmed ksnv]

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

مشكور
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع
قرب الوداع

[ahmed ksnv]

ولا رد .

[veto_44]

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

[Ahmed_ghanam]

مشكورين اخوانى والله موضوع رائع

[hamata00]

الكود يتحط تحت حدث الكليك لزر أوامر
end

[ahmed ksnv]

الكود يتحط تحت حدث الكليك لزر أوامر
end
:smailes91: :smailes13: :smailes100: :smailes44: :smailes44:
كود جميل
هذا الكود للخروج أو لانهاء البرنامج

[kindman_eg]

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

[hamata00]

بسم الله الرحمن الرحيم و الصلاة و السلام على أشرف الأنبياء و المرسلين و بعد :
السلام عليكم شباب و الله أنا حبيت أطبق شغلانة بس مدري ما زبطت معي مدري ليش
المهم أنا لقيت كود لتغيير خلفية سطح المكتب :
في الموديول :
كود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
Public Const SPI_SETDESKWALLPAPER = 20

و في Command Button

كودDim lngSuccess As Long
Dim strBitmapImage As String
strBitmapImage = "C:\WINDOWS\pchealth\helpctr\System\Remote Assistance\Interaction\Server\StopControl.bmp"
lngSuccess = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, strBitmapImage, 0)
بس قلت مع نفسي ليش ما أعدل على الكود إلي في الزر وبدل ما يحط صوة من النظام ..... يعني إلي في المسار ده :
كودC:\WINDOWS\pchealth\helpctr\System\Remote Assistance\Interaction\Server\StopControl.bmp
أضيف للبرنامج Picture Box وأحط فيها صورة ولما أضغط على الزر يتبدل سطح المكتب بالصورة إلي في Picture Box

انتهي الشرح...
السلام عليكم

[yassine]

شكرا لك اخي الكريم
يدمج مع الموضوع المثبت بتاع الاكواد

[hamata00]

ضع الكود في الفورم

Dim Genie As IAgentCtlCharacter
Private Sub Command1_Click()
Genie.Show
End Sub
Private Sub Command2_Click()
Genie.Hide
End Sub

Private Sub Command3_Click()
Genie.Play "Congratulate"
End Sub

Private Sub Command4_Click()
Genie.Play "Pleased"
End Sub

Private Sub Command5_Click()
Genie.Play "lookup"
End Sub

Private Sub Command6_Click()
Genie.Play "Think"
End Sub

Private Sub Form_Load()
Dim Filename
Filename = "ضع مسار المساعد هنا و غالبا ما يكون في المسار التالي\windows\msagent\char"
' علي سبيل المثال
' c:\windows\msagent\char\genie.acs
Agent1.Characters.Load CharacterID:="Genie", LoadKey:=Filename
Set Genie = Agent1.Characters("Genie")
End Sub

[N.A.R.S]

مشكور يالغالي

[hamata00]

9.تشغيل ملف avi بدون ادوات

ضع الكود التالي في الفورم
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

Private Sub Form_Click()
Dim Ret As Long, A$, x As Integer, y As Integer
x = 10
y = 10
A$ = "c:\Filename.avi"
Ret = mciSendString("stop movie", 0&, 128, 0)
Ret = mciSendString("close movie", 0&, 128, 0)
Ret = mciSendString("open AVIvideo!" & A$ & " alias movie parent " & Form1.hWnd & " style child", 0&, 128, 0)
Ret = mciSendString("put movie window client at " & x & " " & y & " 0 0", 0&, 128, 0)
Ret = mciSendString("play movie", 0&, 128, 0)
End Sub

Private Sub Form_DblClick()
End
End Sub

Private Sub Form_Terminate()
Dim Ret As Long
Ret = mciSendString("close all", 0&, 128, 0)
End Sub

[Euro]

This is very good code, thank you very much

[hamata00]

كود خاص لمعرفة كلمة السر لملفات 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

[hamata00]

كود لاستدعاء ملف من نوع mid
*كود برمجي*
قم بوضع اداة
mmcontrol1
كود:

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

[unica]

thnakssssssss

[ahmed ksnv]

كود جميل أوي
كود إخفاء وإظهار زر ابدأ
Const SW_SHOWNORMAL = 1
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias _
"FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_HIDE = 0



Public Function hideStartButton()

OurParent& = FindWindow("Shell_TrayWnd", "")
OurHandle& = FindWindowEx(OurParent&, 0, "Button", _
vbNullString)
ShowWindow OurHandle&, SW_HIDE
End Function

Public Function showStartButton()

OurParent& = FindWindow("Shell_TrayWnd", "")
OurHandle& = FindWindowEx(OurParent&, 0, "Button", _
vbNullString)

ShowWindow OurHandle&, SW_SHOWNORMAL
End Function

Private Sub Command1_Click()
hideStartButton
End Sub

Private Sub Command2_Click()
showStartButton
End Sub


=================================
بمجرد أن تضغط على label1 وتسحب يالماوس يتحرك الفورم!!!!!!!!؟؟؟
نعم إليكم الكود
'&Ouml;&Uacute; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Ccedil;&aacute;&Ecirc;&Ccedil;&aacute;&iacute; &Yacute;&iacute; &THORN;&Oacute; &Ccedil;&aacute;&Igrave;&auml;&Ntilde;&Ccedil;&aacute;
Dim vX, vY
Dim vM As Boolean

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'&Ccedil;&szlig;&Ecirc;&Egrave; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Ccedil;&aacute;&Ecirc;&Ccedil;&aacute;&iacute; &Yacute;&iacute; &Iacute;&Iuml;&Euml; &atilde;&aelig;&Oacute; &Iuml;&aelig;&auml;
vX = X
vY = Y
vM = True

End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'&Euml;&atilde; &Ccedil;&Ouml;&Yacute; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Ccedil;&aacute;&Ecirc;&Ccedil;&aacute;&iacute; &Yacute;&iacute; &atilde;&aelig;&Oacute; &atilde;&aelig;&Yacute;&iacute;
Dim frmX, frmY
frmX = Form1.Left + (X - vX)
frmY = Form1.Top + (Y - vY)
If vM = True Then
Form1.Move frmX, frmY
End If


End Sub

Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'&aelig;&Ccedil;&Icirc;&iacute;&Ntilde; &Ccedil;&Ouml;&Yacute; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Ccedil;&aacute;&Ecirc;&Ccedil;&aacute;&iacute; &Uacute;&auml;&Iuml; &Iacute;&Iuml;&Euml; &atilde;&aelig;&Oacute; &Ccedil;&Egrave;
vM = False

End Sub

[hamata00]

السلام عليكم
عالم الكودات+تصميم برامج أختراق+تصميم مساعد أوفيس المتحرك+ 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

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

[CODE]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

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

[moath.elgabry]

مشكووووووووووووووور
والله هذا جهد عظيم

[MeDaNy]

http://www.9m.com/upload/17-12-2006/02401166321343.gif
http://www.9m.com/upload/17-12-2006/02401166321343.gifhttp://www.9m.com/upload/17-12-2006/02401166321343.gif
http://www.9m.com/upload/17-12-2006/02401166321343.gifhttp://www.9m.com/upload/17-12-2006/02401166321343.gifhttp://www.9m.com/upload/17-12-2006/02401166321343.gif
http://www.9m.com/upload/17-12-2006/02401166321343.gifhttp://www.9m.com/upload/17-12-2006/02401166321343.gif
http://www.9m.com/upload/17-12-2006/02401166321343.gif

[hamata00]

أغلق وأعد تشغيل الجهاز,مع إمهال النظام الوقت الذى تريد
إيكم الكود
' Shutdown Flags
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const SE_PRIVILEGE_ENABLED = &H2
Const TokenPrivileges = 3
Const TOKEN_ASSIGN_PRIMARY = &H1
Const TOKEN_DUPLICATE = &H2
Const TOKEN_IMPERSONATE = &H4
Const TOKEN_QUERY = &H8
Const TOKEN_QUERY_SOURCE = &H10
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_ADJUST_GROUPS = &H40
Const TOKEN_ADJUST_DEFAULT = &H80
Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Const ANYSIZE_ARRAY = 1
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Type Luid
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
'pLuid As Luid
pLuid As LARGE_INTEGER
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Private Declare Function InitiateSystemShutdown Lib "advapi32.dll" Alias "InitiateSystemShutdownA" (ByVal lpMachineName As String, ByVal lpMessage As String, ByVal dwTimeout As Long, ByVal bForceAppsClosed As Long, ByVal bRebootAfterShutdown As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LARGE_INTEGER) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Public Function InitiateShutdownMachine(ByVal Machine As String, Optional Force As Variant, Optional Restart As Variant, Optional AllowLocalShutdown As Variant, Optional Delay As Variant, Optional Message As Variant) As Boolean
Dim hProc As Long
Dim OldTokenStuff As TOKEN_PRIVILEGES
Dim OldTokenStuffLen As Long
Dim NewTokenStuff As TOKEN_PRIVILEGES
Dim NewTokenStuffLen As Long
Dim pSize As Long
If IsMissing(Force) Then Force = False
If IsMissing(Restart) Then Restart = True
If IsMissing(AllowLocalShutdown) Then AllowLocalShutdown = False
If IsMissing(Delay) Then Delay = 0
If IsMissing(Message) Then Message = ""
'Make sure the Machine-name doesn't start with '\'
If InStr(Machine, "\\") = 1 Then
Machine = Right(Machine, Len(Machine) - 2)
End If
'check if it's the local machine that's going to be shutdown
If (LCase(GetMyMachineName) = LCase(Machine)) Then
'may we shut this computer down?
If AllowLocalShutdown = False Then Exit Function
'open access token
If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hProc) = 0 Then
MsgBox "OpenProcessToken Error: " & GetLastError()
Exit Function
End If
'retrieve the locally unique identifier to represent the Shutdown-privilege name
If LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_NAME, OldTokenStuff.Privileges(0).pLuid) = 0 Then
MsgBox "LookupPrivilegeValue Error: " & GetLastError()
Exit Function
End If
NewTokenStuff = OldTokenStuff
NewTokenStuff.PrivilegeCount = 1
NewTokenStuff.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
NewTokenStuffLen = Len(NewTokenStuff)
pSize = Len(NewTokenStuff)
'Enable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, NewTokenStuffLen, OldTokenStuff, OldTokenStuffLen) = 0 Then
MsgBox "AdjustTokenPrivileges Error: " & GetLastError()
Exit Function
End If
'initiate the system shutdown
If InitiateSystemShutdown("\\" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
NewTokenStuff.Privileges(0).Attributes = 0
'Disable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, Len(NewTokenStuff), OldTokenStuff, Len(OldTokenStuff)) = 0 Then
Exit Function
End If
Else
'initiate the system shutdown
If InitiateSystemShutdown("\\" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
End If
InitiateShutdownMachine = True
End Function
Function GetMyMachineName() As String
Dim sLen As Long
'create a buffer
GetMyMachineName = Space(100)
sLen = 100
'retrieve the computer name
If GetComputerName(GetMyMachineName, sLen) Then
GetMyMachineName = Left(GetMyMachineName, sLen)
End If
End Function
Private Sub Form_Load()
InitiateShutdownMachine GetMyMachineName, True, True, True, 60, "You initiated a system shutdown..."
End Sub

[hamata00]

Hide Your Desktop
لاخفاء سطح المكتب

Option Explicit
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Const SPI_SCREENSAVERRUNNING = 97

__________________________________________________ __

Module :---

Option Explicit
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 SWP_HIDEWINDOW = &H80
Public Const SWP_SHOWWINDOW = &H40
Declare Function ShowCursor& Lib "user32" (ByVal bShow As Long)

'----------------------------------------- Code -----------------------------------------

Private Sub cmdDHide_Click()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 0
End Sub
Private Sub cmdDShow_Click()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 5
End Sub
Private Sub cmdExit_Click()
Me.Hide
End
End Sub
Private Sub cmdHelp_Click()
MsgBox "Email me at...home for help", , "Help"
End Sub

[hamata00]

اضافة أوامرالنسخ والقص و اللصق والتراجع والحذف لصندوق النص (Textbox):.

' In Class Name it cTextboxedit Option Explicit

Private Declare Function SendMessageLong Lib "USER32" Alias _
"SendMessageA" (ByVal hWnd As Long , ByVal wMsg As Long , _
ByVal wParam As Long , ByVal lParam As Long) As Long
Private Declare Function SendMessageString Lib "USER32" Alias _
"SendMessageA" (ByVal hWnd As Long , ByVal wMsg As Long , _
ByVal wParam As Long , ByVal lParam As String) As Long

Private Const WM_COMMAND = &H111
Private Const WM_CUT = &H300
Private Const WM_COPY = &H301
Private Const WM_PASTE = &H302
Private Const EM_UNDO = &HC7
Private Const EM_CANUNDO = &HC6
Private Const EM_REPLACESEL = &HC2
Private Declare Function IsClipboardFormatAvailable Lib "USER32" _
(ByVal wFormat As Long) As Long

Private Const CF_TEXT = 1
Private Const CF_UNICODETEXT = 13
Private Const CF_OEMTEXT = 7

Private My_txt As TextBox

Public Property Let TextBox(ByRef New_txt As TextBox)
Set My_txt = New_txt
End Property

Public Sub Cut()
SendMessageLong My_txt.hWnd , WM_CUT , 0 , 0
End Sub

Public Sub Copy()
SendMessageLong My_txt.hWnd , WM_COPY , 0 , 0
End Sub

Public Sub Paste()
SendMessageLong My_txt.hWnd , WM_PASTE , 0 , 0
End Sub

Public Sub Undo()
If (SendMessageLong(My_txt.hWnd , EM_CANUNDO , 0 , 0) < > 0) Then
SendMessageLong My_txt.hWnd , EM_UNDO , 0 , 0
End If
End Sub

Public Property Get CanCut() As Boolean
CanCut = (Not (My_txt.Locked) And My_txt.SelLength > 0)
End Property

Public Property Get CanCopy() As Boolean
CanCopy = (My_txt.SelLength > 0)
End Property

Public Property Get CanPaste() As Boolean
If IsClipboardFormatAvailable(CF_TEXT) Then
CanPaste = True
ElseIf IsClipboardFormatAvailable(CF_UNICODETEXT) Then
CanPaste = True
ElseIf IsClipboardFormatAvailable(CF_OEMTEXT) Then
CanPaste = True
End If
End Property

Public Property Get CanUndo() As Boolean
CanUndo = (SendMessageLong(My_txt.hWnd , EM_CANUNDO , 0 , 0) < > 0)
End Property

Public Sub ReplaceSelection(ByRef sText As String , _
Optional ByVal bAllowUndo = True)
Dim lR As Long
If (My_txt.SelLength > 0) Then
lR = Abs(bAllowUndo)
SendMessageString My_txt.hWnd , EM_REPLACESEL , lR , sText
End If
End Sub

Public Sub Delete(Optional ByVal bAllowUndo = True)
Dim lR As Long
SendMessageString My_txt.hWnd , EM_REPLACESEL , lR , vbNullChar
End Sub

' Placet textbox in form (Text1) Dim New_text As ctextboxedit
Private Sub Form_Load()
Set New_text = New ctextboxedit
New_text.TextBox = Text1
End Sub
' Example of the undo use
Private Sub Command1_Click()
If New_text.CanUndo Then
New_text.Undo
End If
End Sub

[hamata00]

حماية ملف بكلمة مرور

Option Explicit

Private Sub Command1_Click()
End

End Sub


Private Sub Command2_Click()


Dim ContentFile As String
Dim Password As String
Dim FileNumber As Long

' استعراض الملف الذي نود وضع كلمة سر عليه ووضع مساره في عنوان النموذج
With CommonDialog1
.Filter = "كل الملفات (*.*)|*.*|"
.Flags = cdlOFNHideReadOnly Or cdlOFNFileMustExist Or cdlOFNPathMustExist
.DialogTitle = "تحديد الملف"
.FileName = ""
.ShowOpen
If .FileName = "" Then Exit Sub
Caption = .FileName
End With

' تعريف رقم ملف جديد لدى ويندوز
FileNumber = FreeFile

' تهيءة المتحول بحجم الملف الذي سوف يفتح لكي يتم وضع المحتويات به
ContentFile = Space$(FileLen(Trim$(Caption)))

' فتح الملف بشكل ثنائي ووضعه داخل المتحول
Open Trim$(Caption) For Binary As FileNumber
Get #FileNumber , 1 , ContentFile
Close #FileNumber

' فتح مربع الحوار الادخال لوضع كلمة المرورو الجديدة
Password = InputBox("قم بتعيين كلمة المرور للملف على الا تزيد عن ثمانية خانات" , "كلمة مرور")
' تم تحديد عدد الخانات بسبب القرائة من جديد فيجب ان نعرف نقراء من اين اوي مكننا حل المشكلة بوضع علامة مميزة لبدء كلمة المرور ونهايتها مثلا كعلامة #
' كلمة السر#
' اما في حال تحديد العدد المعين فنقوم بملاء الخانات البقاية باصفار وسوف نستخدم هنا الطريقة الاولى
' مع اننا حددنا عدد الخانات ولكن لن نعطي هذا اي اهمية داخل البرمجة حتى ولو زاد العدد عن ثمانية

' وضع كلمة المرور في بداية الملف قبل مكونات الملف الاصلي ويمكن تحديد مكان اخر او تشغيير ملف
' قمنا بوضع العلامة التي تقوم ببيان البداية والنهاية
ContentFile = Password & "#" & ContentFile
' في حال كنت ستسخدم كلمة السر في بايت محدد فانه من الواجب عليك بان تقوم باختيار حرف بداية وحرف نهاية غير معروف او غير مستخدم في تشفير الملف ولذلك انصح بان تستخدم الطريقة التالية
' هذه الطريقة في حال كانة كلمة السر في مكان اخر داخل الملف طبعا لاننا لو قمنا بفتح الملف داخل محرر نصوصو وكانة في البداية فسوف نعرف كلمة المرور
' طبعا هذا الاحتمال وارد وغير وارد فالكثير لايتوقع ان يتم التشفير بهذه الطريقة ولكن البعض يقوم بفتح الملف كما اعمل انا عند ارادة فك كلمة مرور

' يتم اختبار عدد المحارف
' يتم وضع عدد محارف كلمة المرور لكي يتم قرائة هذا العدد من الملف ولكي لانقوم بحذف او تعديل حرف المربع في حال كان ضمن الملف
' طبعا نقوم بذلك بعد ان نقوم بتقسيم الملف لقسمين حتى نضع كلمة المرور في الداخل
' ContentFile = ContentFile1 & "#" & Len(Password) & "#" & Password & "#" & ContentFile2

' يتم فتح الملف مرة اخرى وذلك لتخزين القيم الجديدة به اي بعد وضع كلمة المرور
Open Trim$(Caption) For Binary As FileNumber
Put #FileNumber , 1 , ContentFile
Close #FileNumber

' ولكن ضع في حسبانك ان بعض الملفات لاتتاثر عند وضع كلمة السر في بداية الملف وتفتح بطريقة عادية

End Sub


Private Sub Command3_Click()

Dim ContentFile As String
Dim Password As String
Dim FileNumber As Long
Dim i As Long
Dim ss As String
Dim sss As String
Dim RongPAssword As Integer

' استعراض الملف الذي نود وضع كلمة سر عليه ووضع مساره في عنوان النموذج
With CommonDialog1
.Filter = "كل الملفات (*.*)|*.*|"
.Flags = cdlOFNHideReadOnly Or cdlOFNFileMustExist Or cdlOFNPathMustExist
.DialogTitle = "تحديد الملف"
.FileName = ""
.ShowOpen
If .FileName = "" Then Exit Sub
Caption = .FileName
End With

' تعريف رقم ملف جديد لدى ويندوز
FileNumber = FreeFile

' تهيءة المتحول بحجم الملف الذي سوف يفتح لكي يتم وضع المحتويات به
ContentFile = Space$(FileLen(Trim$(Caption)))

' فتح الملف بشكل ثنائي ووضعه داخل المتحول
Open Trim$(Caption) For Binary As FileNumber
Get #FileNumber , 1 , ContentFile
Close #FileNumber


' يتم قرائة الملف من البداية حتى يتم التاكد من بداية الحرف
' كلمة المرو#

For i = 1 To Len(ContentFile)
' يتم قطع عدد من الاحرف بمقدار الدوارة ووضعها داخل المتغيير حتى يتم اختبار وجود الحرف حتى تاتي العملية التالية
ss = Mid$(ContentFile , 1 , i)
' في حال تم وجود هذا الحرف يتم الخروج من الدوارة كلي تاتي العملية التالية
If Right$(ss , 1) = "#" Then Exit For
Next

' يتم قص كلمة السر من الملف حتى الحرف القبل الاخير والذي هو علامة المربع
sss = Mid$(ss , 1 , (Len(ss) - 1))

' يتم الحصول على كلمة المرور حتى يتم التاكد من صحتها
10 Password = InputBox("هذا الملف محمي بكلمة مرور قم بوضع كلمة المرور حت يتم التاكد منها" , "كلمة المرور")

' يتم التحقق من كلمة المرور في حال كانة صحيحة يتم ازالتها من الملف والا يتم الخروج دون التغيير في الملف
If Password = sss Then
MsgBox "كلمة المرور صحيحة وسوف يتم ازالة الحماية عن الملف"
Else
RongPAssword = MsgBox("كلمة السر هذه خاطئة هل تود المحاولة مرة اخرى " , vbYesNo , "كلمة خاطئة")
' اظهار رسال
If RongPAssword = vbYes Then
' يتم اعادته الى مربع ادخال كلمة السر من جديد
GoTo 10
Else
' يتم الخروج دون تعديل الملف
Exit Sub
End If
End If

' يتم قطع القيمة السابقة من الملف لكي يتم اعادته بدون كلمة مرور
ContentFile = Mid$(ContentFile , i + 1 , Len(ContentFile))

' يتم تخزين الملف بدون كلمة مرور
Open Trim$(Caption) For Binary As FileNumber
Put #FileNumber , 1 , ContentFile
Close #FileNumber




End Sub

[hamata00]

إغلاق النظام (ويندوز XP)

ضع هذا الكود في الفورم




Shutdown Flags
Const EWX_LOGOFF 0
Const EWX_SHUTDOWN 1
Const EWX_REBOOT 2
Const EWX_FORCE 4
Const SE_PRIVILEGE_ENABLED &H2
Const TokenPrivileges 3
Const TOKEN_ASSIGN_PRIMARY &H1
Const TOKEN_DUPLICATE &H2
Const TOKEN_IMPERSONATE &H4
Const TOKEN_QUERY &H8
Const TOKEN_QUERY_SOURCE &H10
Const TOKEN_ADJUST_PRIVILEGES &H20
Const TOKEN_ADJUST_GROUPS &H40
Const TOKEN_ADJUST_DEFAULT &H80
Const SE_SHUTDOWN_NAME SeShutdownPrivilege
Const ANYSIZE_ARRAY 1
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Type Luid
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
pLuid As Luid
pLuid As LARGE_INTEGER
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Private Declare Function InitiateSystemShutdown Lib advapi32.dll Alias InitiateSystemShutdownA (ByVal lpMachineName As String ByVal lpMessage As String ByVal dwTimeout As Long ByVal bForceAppsClosed As Long ByVal bRebootAfterShutdown As Long) As Long
Private Declare Function OpenProcessToken Lib advapi32.dll (ByVal ProcessHandle As Long ByVal DesiredAccess As Long TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib kernel32 () As Long
Private Declare Function LookupPrivilegeValue Lib advapi32.dll Alias LookupPrivilegeValueA (ByVal lpSystemName As String ByVal lpName As String lpLuid As LARGE_INTEGER) As Long
Private Declare Function AdjustTokenPrivileges Lib advapi32.dll (ByVal TokenHandle As Long ByVal DisableAllPrivileges As Long NewState As TOKEN_PRIVILEGES ByVal BufferLength As Long PreviousState As TOKEN_PRIVILEGES ReturnLength As Long) As Long
Private Declare Function GetComputerName Lib kernel32 Alias GetComputerNameA (ByVal lpBuffer As String nSize As Long) As Long
Private Declare Function GetLastError Lib kernel32 () As Long
Public Function InitiateShutdownMachine(ByVal Machine As String Optional Force As Variant Optional Restart As Variant Optional AllowLocalShutdown As Variant Optional Delay As Variant Optional Message As Variant) As Boolean
Dim hProc As Long
Dim OldTokenStuff As TOKEN_PRIVILEGES
Dim OldTokenStuffLen As Long
Dim NewTokenStuff As TOKEN_PRIVILEGES
Dim NewTokenStuffLen As Long
Dim pSize As Long
If IsMissing(Force) Then Force False
If IsMissing(Restart) Then Restart True
If IsMissing(AllowLocalShutdown) Then AllowLocalShutdown False
If IsMissing(Delay) Then Delay 0
If IsMissing(Message) Then Message
Make sure the Machine-name doesnt start with \
If InStr(Machine \\) 1 Then
Machine Right(Machine Len(Machine) - 2)
End If
check if its the local machine thats going to be shutdown
If (LCase(GetMyMachineName) LCase(Machine)) Then
may we shut this computer down?
If AllowLocalShutdown False Then Exit Function
open access token
If OpenProcessToken(GetCurrentProcess() TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY hProc) 0 Then
MsgBox OpenProcessToken Error: & GetLastError()
Exit Function
End If
retrieve the locally unique identifier to represent the Shutdown-privilege name
If LookupPrivilegeValue(vbNullString SE_SHUTDOWN_NAME OldTokenStuff.Privileges(0).pLuid) 0 Then
MsgBox LookupPrivilegeValue Error: & GetLastError()
Exit Function
End If
NewTokenStuff OldTokenStuff
NewTokenStuff.PrivilegeCount 1
NewTokenStuff.Privileges(0).Attributes SE_PRIVILEGE_ENABLED
NewTokenStuffLen Len(NewTokenStuff)
pSize Len(NewTokenStuff)
Enable shutdown-privilege
If AdjustTokenPrivileges(hProc False NewTokenStuff NewTokenStuffLen OldTokenStuff OldTokenStuffLen) 0 Then
MsgBox AdjustTokenPrivileges Error: & GetLastError()
Exit Function
End If
initiate the system shutdown
If InitiateSystemShutdown(\\ & Machine Message Delay Force Restart) 0 Then
Exit Function
End If
NewTokenStuff.Privileges(0).Attributes 0
Disable shutdown-privilege
If AdjustTokenPrivileges(hProc False NewTokenStuff Len(NewTokenStuff) OldTokenStuff Len(OldTokenStuff)) 0 Then
Exit Function
End If
Else
initiate the system shutdown
If InitiateSystemShutdown(\\ & Machine Message Delay Force Restart) 0 Then
Exit Function
End If
End If
InitiateShutdownMachine True
End Function
Function GetMyMachineName() As String
Dim sLen As Long
create a buffer
GetMyMachineName Space(100)
sLen 100
retrieve the computer name
If GetComputerName(GetMyMachineName sLen) Then
GetMyMachineName Left(GetMyMachineName sLen)
End If
End Function
Private Sub Form_Load()
InitiateShutdownMachine GetMyMachineName True True True 60 You initiated a system shutdown...
End Sub

[shania]

lita7rik label



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

[hamata00]

شكرا علي ردودكم