أكواد vb للفائدة نرجو من الجميع المشاركة

* تحميل جميع خطوط الكمبيوتر في ComboBox


كود:
Private
Sub Form_Load() Dim i As Integer For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i) Next i Combo1******* = Combo1.List(0)
End Sub



* تغيير صفحة البدء في الانترنت اكسبلورر


كود:
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://www.boca.yoo7.com") End Sub



* التحكم بالسي دي


كود:
Private
Declare Function mciSendString Lib "winmm.dll" Alias _ "mciSendStringA"
(ByVal lpstrCommand As String, ByVal _ lpstrReturnString As String,
ByVal uReturnLength As _ Long, ByVal hwndCallback As Long) As Long
Private Sub OpenCdDoor(Opn As Boolean) str_State = IIf(Opn, "Open",
"Closed") mciSendString "set CDAudio door " & str_State, vbNulChar,
127&, 0& End Sub 'عند الاستدعاء 'للفتح OpenCdDoor True 'للاغلاق
OpenCdDoor False



* لتشغيل شاشة التوقف


كود:
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)



* لتحديد دقة عرض الشاشة


كود:
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



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


كود:
Private
Sub Command1_Click() Picture1.ScaleMode = vbPixels x =
Picture1.ScaleWidth y = Picture1.ScaleHeight For i = 0 To y - 1 For j =
0 To x - 1 pixel = Picture1.Point(j, i) red = pixel Mod 256 green =
((pixel And &HFF00) / 256) Mod 256 blue = (pixel And &HFF0000)
/ 65536 g = ((red * 30) + (green * 60) + (blue * 20)) / 100
Picture1.PSet (j, i), RGB(g, g, g) Next Next Picture1.ScaleMode =
vbTwips End Sub



* خلفية متدرجة باللون الأزرق مثل برامج الإعداد


كود:
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



* لإطفاء الشاشة وتشغيلها


كود:
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&



* كود لمعرفة الاتصال


كود:
Private
Declare Function InternetGetConnectedState _Lib "wininet.dll" (ByRef
lpSFlags As Long, _ByVal dwReserved As Long) As LongPrivate Sub
Command1_Click() If InternetGetConnectedState(0&, 0&) Then
MsgBox "OnLine"Else MsgBox "OffLine" End If End Sub



* لاخفاء موشر الفارة


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



* طريقة لمعرفة أكبر رقم من بين 10 أرقام مدخلة


كود:
Function
ReturnLargest(ByVal i As Integer, ByVal Number As Integer, ByVal
MaxNumber As Integer) MaxNumber = 0 For i = 1 To 10 Number =
InputBox("أدخل رقم بين 1 و 32000", "Number") Print Number If MaxNumber
> i Then MaxNumber = MaxNumber Else MaxNumber = Number End If Next i
Print vbNewLine Print "أكبر رقم هو " & MaxNumber End Function
Private Sub Command1_Click() Dim Max, Count, Number, Largest As Integer
Max = ReturnLargest(Count, Number, Largest) End Sub



* للتحكم في اعدادات الفأرة


كود:
****l("rundll32.exe ****l32.dll,Control_RunDLL access.cpl,,5")



* لاضافة جهاز جديد


كود:
****l("rundll32.exe ****l32.dll,Control_RunDLL sysdm.cpl @1")



* لتغيير صورة خلفية سطح المكتب :


كود:
'Module
File هذا الجزء في ملف برمجي 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:\windows\straw.bmp" lngSuccess =
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, strBitmapImage, 0) End Sub



* لإخفاء البرنامج من قائمة إنهاء المهام :-


كود:

'Module
File هذا الجزء في ملف برمجي Public Declare Function GetCurrentProcessId
_ Lib "kernel32" () As Long Public Declare Functio