• 0
JAAS

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

سؤال

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

في البداية : أتقدم بالشكر لكل الأعضاء الذين ساهموا في نشر

علوم البرمجة والعلوم الأخرى

وأقول لهم ( أن جهدكم لن يضيع بسهولة )

وتحت هذا الشعار فإني أقدم لكم مجموعة من الأكواد والأفكار

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

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

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

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

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 [url]http://arabteam.nicmatic.com")[/url], vbNormalNoFocus

2 : تنفيذ الكود بعد فترة زمنية

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

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

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

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

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

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

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

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

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

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("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"

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

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

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

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

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

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

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&

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

-

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

38 إجابة على هذا السؤال .

  • 0

يتبع

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

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  

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

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

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

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

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

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

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

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

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

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

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)

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

27 : فتح برنامج محرر النصوص وكتابة جملة

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

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

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

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

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

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

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

تابع

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

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

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

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

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

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

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

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

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

41 : لإيقاف تشغيل الويندوز بدون APIs

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

42 : لمعرفة حجم ملف

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

43 : لعرض جميع الطابعات بدون APIs

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

44 : عدم تشغيل اكثر من نسخه من برنامجك

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

45 : معرفة مسار مجلد الوندوز

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

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

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

47 : حذف جميع الملفات داخل مجلد

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

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

shell "C:\WINDOWS\CALC.EXE

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

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

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

--

هذا والله أعلم

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

شكرا جدا على مجهودك فعلا اكواد حلوة جدا

:D

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

جميل جدا يا jaas جربت بعضها وتعمل بشكل رائع، بارك الله فيك.

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

مشكور على المجموعة المتميزة من الأكواد والأفكار البرمجية

تحياتي

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم ...

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

و السلام عليكم ..

بنت اليمن ،،

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

مشكور على كل جهد قمت به

واتمنا لك التوفيق

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

شكرا كثيرا أخي و بصراحة أغلب الأكواد جربتها و اكثر من رائعة

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم ...

لا تعليق لدي قبل المشاركة هنا الا اقتباساً من ما قاله الاخ المبدع jaas ......

في البداية : أتقدم بالشكر لكل الأعضاء الذين ساهموا في نشر

علوم البرمجة والعلوم الأخرى

وأقول لهم ( أن جهدكم لن يضيع بسهولة )

وتحت هذا الشعار فإني أقدم لكم مجموعة من الأكواد والأفكار

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

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

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

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

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

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

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

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

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

Private Sub Command1_Click()
MsgBox Format(GetTickCount, "0")
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

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

+ كود تستطيع من خلاله حذف اي ملف

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

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

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

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

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

+ لإنهاء صلاحيات برنامجك التجريبي بعد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 Declare Function PaintDesktop Lib "user32" _ 
(ByVal hdc As Long) As Long

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

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

+ فورم دائري

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

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

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

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

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

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

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

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

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

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

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

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

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

و السلام عليكم ....

بنت اليمن ..

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0
و بإذن الله سوف اشارك معك في اقرب فرصة .. من اجل جعل الموضوع مرجع في الاكواد و الافكار في المنتدى

شكر وتقدير على المشاركة

ولو كل عضو يضع كود واحد = مشاركة في نشر العلم وفائدة لة قبل كل شيء

للفائدة العامة

وبالتوفيق

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم أحب اشكرك كثيرا علي هذه الاكواد الرائعة

ولكن لدي تعليق بيسط

في الكود رقم 18 توجد مسافة زائدة قبل تعريق قيمة X لذلك تظل في وقت التنفيذ

"Empty"

للأسف لم يسعني قراءة أو استخدام باقي الأكواد ولكن أرجو المزيد من الأفكار

وأرجو الا يضايقك تنبيهي لإانا مجرد مبربج بسيط

وشكرا مرة أخري

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

شكرا جزيلا على هذا المجهود الرائع

ولو كان هناك ملاحظه بسيطة على كل كود في اي حدث يوضع

جزاك الله كل خير على ما قدمت ولكل من قام بتوصيل معلومه ونشرها في هذا المنتدى الرائع

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

مشكور اخوي على الجهود الف شكر

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم من باب المشاركه سأضيف كودين

هذا الكود يجعل النص عمودي label 1

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

وهذا الكود مؤثر جميل للفورم

Function Dist(x1, y1, x2, y2) As Single 

Dim A As Single, B As Single

A = (x2 - y1) * (x2 - x1)

B = (y2 - y1) * (y2 - y1)

Dist = Sqr(A + B)

End Function

Sub MoveIt(A, B, t)

A = (1 - t) * A + t * B

End Sub



Private Sub Form_Click()

Cls

Dim t As Single, x1 As Single, y1 As Single

Dim x2 As Single, y2 As Single, x3 As Single

Dim y3 As Single, x4 As Single, y4 As Single



Scale (-320, 200)-(320, -200)

t = 0.05

x1 = -320: y1 = 200

x2 = 320: y2 = 200

x3 = 320: y3 = -200

x4 = -320: y4 = -200

Do Until Dist(x1, y1, x2, y2) < 10

Line (x1, y1)-(x2, y2)

Line -(x3, y3)

Line -(x4, y4)

Line -(x1, y1)

MoveIt x1, x2, t

MoveIt y1, y2, t

MoveIt x2, x3, t

MoveIt y2, y3, t

MoveIt x3, x4, t

MoveIt y3, y4, t

MoveIt x4, x1, t

MoveIt y4, y1, t

Loop

End Sub



Private Sub Form_Resize()

Cls

Dim t As Single, x1 As Single, y1 As Single

Dim x2 As Single, y2 As Single, x3 As Single

Dim y3 As Single, x4 As Single, y4 As Single



Scale (-320, 200)-(320, -200)

t = 0.05

x1 = -320: y1 = 200

x2 = 320: y2 = 200

x3 = 320: y3 = -200

x4 = -320: y4 = -200

Do Until Dist(x1, y1, x2, y2) < 10

Line (x1, y1)-(x2, y2)

Line -(x3, y3)

Line -(x4, y4)

Line -(x1, y1)

MoveIt x1, x2, t

MoveIt y1, y2, t

MoveIt x2, x3, t

MoveIt y2, y3, t

MoveIt x3, x4, t

MoveIt y3, y4, t

MoveIt x4, x1, t

MoveIt y4, y1, t

Loop

End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

إضافة تأثير ثلاثي الأبعاد علي مكونات الفورم وعلي الفورم

 
'Form 3D objects code Copyright © 2003 Ahmad farag.
  'All Rights Reserved. [email protected]
' First I need to thank the owner of the site for this service

Sub PaintControl3D(frm As Form, Ctl As Control)
  ' This Sub draws lines around controls to make them 3d
  ' Like this in objects in the toolbars
 
  'Horizontal lines
  ' darkgrey, upper - horizontal
  frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _
        Ctl.Width, Ctl.Top - 15), &HFFFFFF, BF
  ' white, lower - horizontal
  frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _
  (Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &H808080, BF
 
  'Vertical lines
  ' darkgrey, left - vertical
  frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _
       Ctl.Top + Ctl.Height), &HFFFFFF, BF
  ' white, right - vertical
  frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _
    (Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &H808080, BF

End Sub

Sub PaintForm3D(frm As Form)
  ' This Sub draws lines around the Form to make it 3d
 
  'Horizontal lines
  ' white, upper - horizontal
  frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF
  ' darkgrey, lower - horizontal
  frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _
    frm.ScaleHeight - 15), &H808080, BF
 
  'Vertical lines
  ' 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

End Sub

Private Sub Form_Load()

  Dim Con As Control
 
'Set form's AutoRedraw property to True, or leave it to code
  Me.AutoRedraw = True
  PaintForm3D Me
  'To make 3D effect all controls in the form
  For Each Con In Me.Controls
  'For labels Only, you can use this code
      'If TypeOf Con Is Label Then
          PaintControl3D Me, Con
      'End If
  Next
 
'You can change labels to everything you need
'Or make it like this one by one
'PaintControl3D Me, Label1  'Label1 is name of label
'PaintControl3D Me, Text1   'Text1 is name of textbox

End Sub

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

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

وكود آخر لتنظيف كل text Boxs في النافذة

Public Sub ClearTextBoxes(frmClearMe As Form)

Dim txt As Control

'clear the text boxes
For Each txt In frmClearMe

 If TypeOf txt Is TextBox Then txt.Text = ""

Next

End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

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

'Write the code below to the forms mouse_down event:
CurX = X
CurY = Y

'Write this code below to the forms mouse_move event:
If button = 1 then 'use mouse_left_button
  Me.move Me.left + (X - CurX), Me.top + (Y - CurY)
End If

'Run the program, and try to drag the form...
'Enjoy it....

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

ويقوم هذا الكود برسم مستطيل خلف كل كائن لعمل ظل له

Public Sub Shadow(f As Form, c As Control, clr As Long)
'This SubRoutine draws a shadow below and to the
'the right of a control.It's quite a simple exmpl
'of drawing in form !

'Example : Shadow Me,Text1,vbBlack

'Contact me at [email protected]

Const shWidth = 3       'Width of the shadow
Dim oldWidth As Integer 'Save old DrawWidth
Dim oldScale As Integer 'Save old ScaleMode

f.AutoRedraw = True 'optional, but otherwise
'shadow won't remain when form is repainted
'or call from the Form_Paint() sub


oldWidth = f.DrawWidth  'Remember current DrawWidth
oldScale = f.ScaleMode  'Remember current ScaleMode

f.ScaleMode = 3         'Set to pixel scaling
f.DrawWidth = 1         '1 pixel width lines

'Draws the shadow by drawing a box behind the control
f.Line (c.Left + shWidth, c.Top + shWidth)- _
Step(c.Width - 1, c.Height - 1), clr, BF


f.DrawWidth = oldWidth  'Restore old DrawWidth
f.ScaleMode = oldScale  'Restore old ScaleMode

End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

يقوم هذا الكود بغلق او اعدة تشغيل الجهاز

Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_LOGOFF = 0
Const EWX_FORCE = 4
Private Declare Function ExitWindowsEx Lib "user32(ByVal uFlags As Long, _
ByVal dwReserved As Long) As Long

الشفرة 'cmdRestart اصنع زر تحكم باسم
Private Sub cmdRestart_Click()
'Restart Windows (works on Windows 95/NT)
ExitWindowsEx EWX_LOGOFF, 0
End sub

أو استخدام هذا الكود للغلق

Private Const EWX_SHUTDOWN As Long = 1

Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long

الشفرة 'cmdRestart اصنع زر تحكم باسم
Private Sub cmdRestart_Click()
lngResult = ExitWindowsEx(EWX_SHUTDOWN, 0&)
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

مشكووووووووور أخي jaaz

على ماقدمته من أكواد بارك الله فيك وفي من ساهم في نشر هذه الأكواد

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

مشكوووووووور أخي jaas

أشكرك وأشكر كل من ساهم في نشر هذه الأكواد

بارك الله فيك وفي القائمين على هذا المنتدى .

أسأل الله العلي القدير أن يجعل هذا العمل في موازين حسناتك وحسناتهم .

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

وفقك الله أخي على المجهود المفيد والعظيم نفع الله بها كل مسلم !!!

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

ما شاء الله عليك

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

من اروع ما وجدت في منتدى الفريق العربي وقد استفدت منه كثرا حتى اني خليته مرجع لي.

بارك الله فيك ..

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

اي كان هذا الموضوع أول مرة أراه

فعلا موضوع رائع والتمس من الأخوة المشرفين تثبيت الموضوع حتى يكون مرجع دائم لكل من لدية كود أو فكرة عمل حتى يكون دليل لكل مبرمجي الفيجوال بيسك

شكرا لك أخي jass عل فكرة الموضوع

ودائما أخي تفاجئنا ........

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
زوار
This topic is now closed to further replies.

  • يستعرض القسم حالياً   0 members

    لا يوجد أعضاء مسجلين يشاهدون هذه الصفحة .