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

يتبع

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

تابع

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

--

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

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

:D

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

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

تحياتي

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

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

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

بنت اليمن ،،

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

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

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

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

لا تعليق لدي قبل المشاركة هنا الا اقتباساً من ما قاله الاخ المبدع 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")

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

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

بنت اليمن ..

اقتباس

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

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

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

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

وبالتوفيق

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

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

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

"Empty"

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

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

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

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

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

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

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

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

هذا الكود يجعل النص عمودي 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

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

 
'Form 3D objects code Copyright © 2003 Ahmad farag.
   'All Rights Reserved. ahm_farag@hotmail.com
' 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

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

وكود آخر لتنظيف كل 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

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

'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....

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

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 ehasan@citechco.net

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

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

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

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

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

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

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

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

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

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

السلام عليكم

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

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

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