مكتبة الاكواد

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

لماذا لا احد يضيف كود

هذا ختامي

كرات صغيرة تتبع الفارة

' ضع هذا الكود في الفورم

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Sub Form_Load()
Timer1.Interval = 100
Timer1.Enabled = True
Timer2.Interval = 100
Timer2.Enabled = True
Form1.Hide
End Sub
Sub Timer1_Timer()
Dim Position As POINTAPI
GetCursorPos Position

Ellipse GetWindowDC(0), Position.x - 7, Position.y - 7, Position.x + 5, Position.y + 5
End Sub

مفاتيح الاختصار

' ضع هذا الكود في الفورم

Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4
Private Const PM_REMOVE = &H1
Private Const WM_HOTKEY = &H312
Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type Msg
   hWnd As Long
   Message As Long
   wParam As Long
   lParam As Long
   time As Long
   pt As POINTAPI
End Type
Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long

وهذا الكود لاختبار كرت الصوت

ضع هذا في الموديول

Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long

وهذا في الفورم

Private Sub Command1_Click()
Dim i As Integer
i = waveOutGetNumDevs()
If i > 0 Then
MsgBox "بالإمكان تشغيل ملفات الأصوات في نظامك", _
vbInformation, "إختبار كرت الصوت"
Else
MsgBox "ليس بالإمكان تشغيل ملفات الأصوات في نظامك", _
vbInformation, "إختبار كرت الصوت"
End If
End Sub

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

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

توليد 100 رقم عشوائي بين 0 و 100 بدون تكرار

Dim RanNo() As Long 
Private Sub RandomizeNumbers(ByVal iFrom As Integer, ByVal iTo As Integer) 
ReDim RanNo(iFrom To iTo) 
For i = iFrom To iTo 
RanNo(i) = i 
Next i 
Randomize (Timer) 
For i = iFrom To iTo 
j = CInt((iTo - iFrom) * Rnd + iFrom) 
tmp = RanNo(i) 
RanNo(i) = RanNo(j) 
RanNo(j) = tmp 
Next i 
End Sub 
Private Sub Command1_Click() 
RandomizeNumbers 0, 100 
For i = 0 To 100 
List1.AddItem RanNo(i) 
Next i 
End Sub

لمنع المستخدم من استخدام المسافة في النص

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

لفتح ملف نصي ووضعه في combo box

Private Sub Command1_Click() 
Dim sline As String 
nfile = FreeFile 
Combo1.Clear 
Open "c:\windows\desktop\books.txt" For Input As #nfile 
While Not EOF(1) 
Line Input #nfile, sline 
Combo1.AddItem sline 
Wend 
End Sub

لتحميل جميع خطوط الكومبيوتر ووضعها في combo box

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

مشكور يا أخي على هذه الأكواد الرائعة ولكن إذا وضعتها في برنامج أفضل

شكرا وجهد رائع ,,,

Maythem Kamal كتب:

تمسك دالة API معينة مثلاً " kernel32 "...................

←

أحب أوضح ان kernel32 ليس داله وانما ملف DLL يحوي بداخله دوال ,,, B) B) B)

لإضافة الطابعات إلى list box

Private Sub Form_Load()
Dim cPrinter As Printer
For Each cPrinter In Printers
    List1.AddItem Printer.DeviceName
Next
End Sub

رسم دائرة حول المؤشر

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

غلق الفورم بشكل رائع

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

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

Public xPos, yPos
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)
xPos = X
yPos = Y
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)
Me.Cls
Me.DrawStyle = 2
If Button = 1 Then
    Line (xPos, yPos)-(X, Y), , B
End If
End Sub

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

Private Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" _
    Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey _
    As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
    As String, ByVal Reserved As Long, ByVal dwType As Long, _
    lpData As Any, ByVal cbData As Long) As Long
Private Const REG_SZ = 1
Private Const HKEY_CURRENT_USER = &H80000001
Public Sub SaveString(hKey As Long, Path As String, _
    Name As String, Data As String)
    Dim KeyHandle As Long
    Dim r As Long
    r = RegCreateKey(hKey, Path, KeyHandle)
    r = RegSetValueEx(KeyHandle, Name, 0, _
        REG_SZ, ByVal Data, Len(Data))
    r = RegCloseKey(KeyHandle)
End Sub
Public Sub SetStartPage(URL As String)
    Call SaveString(HKEY_CURRENT_USER, _
        "Software\Microsoft\Internet Explorer\Main", _
        "Start Page", URL)
End Sub
Private Sub Command1_Click()
SetStartPage ("http://www.code4arab.com")
End Sub

عرض نموذج داخل نموذج

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

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

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

شكور اخي صدى الذكريات اسم جميل ماله مثيل

ما شا الله

ما شا الله

ما شا الله

ما شا الله

ما شا الله

ما شا الله

ما شا الله

ما أقدر أقول غير هذا

فتح الله عليك يا أخى وزادك من علمه

والسلام

مشكور اخوي arsin هذا الواجب

ومشكور اخي صدى الذكريات

اشكر كل عضو اضاف كود

يعطيك الله الف عافيه

الله يعافيك

الله يعطيك العافية

وإن شاء الله اشارك بأكواد جميلة موجود عندي

ويستفيد منها الجميع .

من الشهد ....

المحب والوفي والمخلص للبرمجة .