السلام عليكم و رخمة الله و بركاته

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

ان شاء الله استفيد بخبرتكم :

الكود الاول :
تغيير خلفية الجهاز

CODE

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

يا اخوان اتمنى التفاعل في الردود .

و هذا الكود الثاني :
: تحريك الفورم بمفاتيح الأسهم في لوحة المفاتيح

CODE

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

هلا بكم

هذا الكود الثالث :
جعل البرنامج يعمل مع بدء تشغيل وندوز

CODE

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

هلا يا اخوان

هذا الكود الرابع :

و هو شيّق بغض الشيء :

كود لقلب الشاشة عموديا

CODE

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

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

هذا الكود الخامس :

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

CODE

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&

هذا الكود السادس :

معرفة العنصر الذي تحت مؤشر الماوس في القائمة

CODE

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

هذا الكود السابع :

إفراغ سلة المحذوفات

CODE

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

هذا الكود الثامن :

جلب معلومات البويس

CODE

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

هذا الكود التاسع :
رسم دائرة صغيرة حول مؤشر الماوس تتبع حركتة

CODE

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

هذا الكود العاشر :

إغلاق الفورم بشكل تدرجي

CODE

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

هذا الكود الحادي عشر :

هل تريد إخفاء برنامجك من قائمة Ctrl+Alt+Del

CODE

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

هذا الكود الثاني عشر :

تشغيل حافظة الشاشة

CODE

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)

هلا شباب ملليت من العد ممكن تردوا عليّ

المهم

هذا الكود :

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

CODE

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

هلا

هذا كود آخر :
تغيير صفحة البدء لمتصفح الإنترنت

CODE

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

هلا

هذا كود آخر :

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

CODE

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)

هذا كود آخر :

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

CODE

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

هذا كود آخر :

إقاف عمل الماوس والكيبورد

CODE

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

السلام عليكم ورحمة الله و بركاته

الاخ العزيز الريامي لا شكر على واجب

بل اشكرك انت على المرور

و لك جزيل الشكر بس اتمنى انك

تتفاعل معي في موضوعي كما تفاعلت انا سابقا

ولا تبخل علينا باكوادك و خبرتك و افكارك و مقترحاتك

يا الاخ العزيز الريامي بارك الله فيك .

و السلام مسك الختام

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

وين التفاعلات يا اخواني الاعزاء


؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

السلام عليكم و رحمة الله و بركاته

لا شكر على واجب اخي العزيز

فهدفي في هذا الصرح العلمي الالكتروني

الاستفادة و الافادة .

كلا و لن ابخل عليكم اخواني الاعزاء

و شكرا لك اخي العزيز على المرور و الرد

بماان الاستفادة من هذا الصرح العلمي الاكتروني

قد تحققت فآمل من الله ان احقق لكم الافادة

الاخ العزيز يحيي ارجو ان تساهم و تفيد معنا في موضوعي

و ارجو منك التفاعل بارك الله فيك .

و السلام عليكم و رحمة الله و بركاته

و السلام مسك الختام .

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

فآمل انك قد وجدت ظآلتك المنشودة من الكودات

و فقك الله .

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

لا شكر على واجب

لا شـــــــــكر على واجـــــب يا اخــــــــــوانى **

السلام عليكم و رحمة الله و بركاته

تكملة لسلسلة الاكــواد الســـابقة **

&Ouml;&Uacute; &aring;&ETH;&Ccedil; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Yacute;&iacute; &Ccedil;&aacute;&Yacute;&aelig;&Ntilde;&atilde;

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

Private Sub Command2_Click()
OpenCDDriveDoor (False)
End Sub

و هذا كود لاخفاء زر ابدأ و اظهاره

Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Sub Command1_Click()
Dim Task As Long
Task = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub

Private Sub Command2_Click()
Dim Task As Long
Task = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub

حالة الاتصال بالانترنت من خلال الريجيستري :

'In a Module..
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 RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as string, you must pass it By Value.
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002

Public Function IsConnected() As Boolean
Dim lRegKey As Long
Dim bData(3) As Byte

If RegOpenKey(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\RemoteAccess", lRegKey) = 0 Then
'Opened RegKey Successfully..
If RegQueryValueEx(lRegKey, "Remote Connection", 0&, 1&, bData(0), 4) = 0 Then
'Query the Value of "Remote Connection" 1 - Connected, 0 - Not Connected
IsConnected = bData(0)
Else
'Counldn't find the Value, assume no Connection
IsConnected = False
End If
'Close the Registry Key
Call RegCloseKey(lRegKey)
End If
End Function

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

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