--((الموسوعة الضخمة لأكواد وأفكار الفيجويل))---

الريامي · 24 نوفمبر 2004، 16:56

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

الريامي · 24 نوفمبر 2004، 16:57

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

الريامي · 24 نوفمبر 2004، 16:58

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

الريامي · 24 نوفمبر 2004، 16:58

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

الريامي · 24 نوفمبر 2004، 16:59

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

الريامي · 24 نوفمبر 2004، 17:00

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

الريامي · 24 نوفمبر 2004، 17:00

Set iii= CreateObject("wscript.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"

الريامي · 24 نوفمبر 2004، 17:01

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

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

الريامي · 24 نوفمبر 2004، 17:01

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

الريامي · 24 نوفمبر 2004، 17:02

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&

الريامي · 24 نوفمبر 2004، 17:03

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

الريامي · 24 نوفمبر 2004، 17:03

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

الريامي · 24 نوفمبر 2004، 17:04

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

الريامي · 24 نوفمبر 2004، 17:04

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

الريامي · 24 نوفمبر 2004، 17:04

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

الريامي · 24 نوفمبر 2004، 17:05

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

الريامي · 24 نوفمبر 2004، 17:05

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

الريامي · 24 نوفمبر 2004، 17:06

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

الريامي · 24 نوفمبر 2004، 17:06

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

الريامي · 24 نوفمبر 2004، 17:07

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

الريامي · 24 نوفمبر 2004، 17:07

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)

الريامي · 24 نوفمبر 2004، 17:08

أضف نموذجين 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

الريامي · 24 نوفمبر 2004، 17:08

أضف 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

الريامي · 24 نوفمبر 2004، 17:09

ضف 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

الريامي · 24 نوفمبر 2004، 17:09

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

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

الريامي · 24 نوفمبر 2004، 17:10

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
كل ضغطة على زر الأمر تغير اللغة

الريامي · 24 نوفمبر 2004، 17:10

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

الريامي · 24 نوفمبر 2004، 17:11

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

الريامي · 24 نوفمبر 2004، 17:11

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

الريامي · 24 نوفمبر 2004، 17:12

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

--((الموسوعة الضخمة لأكواد وأفكار الفيجويل))---

تغيير خلفية الجهاز

تشغيل ملف صوتي

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

رسم مؤشر الماوس على الفورم

تجميد برنامج وإعادة تنشيطة

جعل البرنامج يعمل مع بدء تشغيل وندوز

جعل البرنامج يعمل مع بدء تشغيل وندوز طريقة ثانية

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

فتح ملف نصي ووضعة في أداة نص

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

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

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

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

رسم إحداثيات

إغلاق أي برنامج بمعرفة عنوان النافذة

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

هل تريد منع المستخدم من استخدام المسافة في صندوق النص

لتوسيط الفورم وسط الشاشة استخدم الإجراء التالي

التراجع عن الإجراء الأخير في مربع نص

تغيير صفحة البدء لمتصفح الإنترنت

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

عرض فورم داخل فورم

طريقة الضغط على زر الامر برمجيا بطريقة مرئية

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

النسخ من و الى الحافظه

تغيير الكتابة من العربي إلى الإنجليزي وبالعكس

معرفة وتغيير ألوان واجهة وندوز

عرض نافذة تهيئة الأقراص -فورمات

إنشاء قائمة وعرضها عند الضغط بالزر الأيمن للماوس على الفورم

حذف الرموز الغير مرغوب بها من جملة نصية

مشاركة