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

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

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

Private Sub Command1_Click()
MsgBox ("عدد الحروف = " + Str(Len(Text1.Text)))
End Sub

عكس اتجاه النص

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

Public Function reversestring(revstr As String) As String
Dim doreverse As Long
reversestring = ""
For doreverse = Len(revstr) To 1 Step -1
reversestring = reversestring & Mid$(revstr, doreverse, 1)
Next
End Function

Private Sub Command1_Click()
Dim strResult As String
strResult = reversestring(Text1.Text)
Text2.Text = strResult
End Sub

شكرا يا أخ ghost 2010

ولكن المتصفحين للمنتدى يمكن مايدلونه

وشكرا جزيلاً

:lol: :lol: :lol: :rolleyes:

تغير لون النص بأستمرار

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

Private Sub Timer1_Timer()
Static Col1, Col2, Col3 As Integer
Static c1, C2, C3 As Integer
If (Col1 = 0 Or Col1 = 250) And (Col2 = 0 Or Col2 = 250) And (Col3 = 0 Or Col3 = 250) Then
c1 = Int(Rnd * 3)
C2 = Int(Rnd * 3)
C3 = Int(Rnd * 3)
End If
If c1 = 1 And Col1 <> 0 Then Col1 = Col1 - 10
If C2 = 1 And Col2 <> 0 Then Col2 = Col2 - 10
If C3 = 1 And Col3 <> 0 Then Col3 = Col3 - 10
If c1 = 2 And Col1 <> 250 Then Col1 = Col1 + 10
If C2 = 2 And Col2 <> 250 Then Col2 = Col2 + 10
If C3 = 2 And Col3 <> 250 Then Col3 = Col3 + 10
Label1.ForeColor = RGB(Col1, Col2, Col3)
End Sub
Private Sub Form_Load()
Timer1.Interval = 100
End Sub

جعل خلفيه النص تومض

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

Private Sub Timer1_Timer()
Static COL
COL = COL + 10
If COL > 510 Then COL = 0
Label1.BackColor = RGB(Abs(COL - 255), 0, 0)
Label2.BackColor = RGB(0, Abs(COL - 255), 0)
Label3.BackColor = RGB(0, 0, Abs(COL - 255))
Label4.BackColor = RGB(Abs(COL - 0), 180, 180)
Label5.BackColor = RGB(Abs(COL - 200), 30, 180)
End Sub

أكواد النسخ والقص واللصق

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

 Private Sub Command1_Click()
Clipboard.Clear
Clipboard.SetText text1
End Sub

Private Sub Command2_Click()
Clipboard.Clear
Clipboard.SetText text1
text1 =""
End Sub

Private Sub Command3_Click()
text1 = Clipboard.GetText
End Sub

تحويل الاحرف من كبيرة الى صغيرة والعكس

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

Private Sub Command1_Click()
x = Text1.Text
y = UCase(Left(x, Len(x)))
Text1.Text = y
End Sub
Private Sub Command2_Click()
x = Text1.Text
y = LCase(Left(x, Len(x)))
Text1.Text = y
End Sub

إنشاء مربع نص وقت تنفيذ البرنامج

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

Private Sub Form_Load()
Form1.Controls.Add "VB.textbox", "Textcreate", Form1
Form1!Textcreate.Visible = True
End Sub

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

أخي برووفيشنال بارك الله فيك على مجهودك الطيب, و لكن عندي أقتراح, ( هو مجرد أقتراح أنا شخصياً أجده أنفع شوي ), و هو أنه تمسك دالة API معينة مثلاً " kernel32 " و تشرحها بالتفصيل بحيث يفهم القاريء ماهي دالة الـ "kernel32" و ماذا تعمل و كيف أستخدمها ( أقصد شرح أيعازاتها), و سعيك مشكور.

أخوك ميثم كمال

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

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

Private Sub Text1_KeyPress(KeyAscii As Integer)
If (KeyAscii >= Asc("a") And KeyAscii <= Asc("z")) Or (KeyAscii >= Asc("A") And KeyAscii <= Asc("Z")) Then
Else
KeyAscii = 0
End If
End Sub

السماح بكتابة أرقام فقط داخل مربع النص

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

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub

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

عفواً فقط أنا لا أقصد فقط شرح دالة الـ "kernel32" و أنما قصدي أي دالة أخرى.

السماح بإدخال تاريخ فقط في مربع النص

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

Dim i As Integer
Dim t1 As String
Dim t2 As String
Public Sub AutoDate(TextBoxName As TextBox, ByVal keyasci As Integer)
   If Val(keyasci) = 8 Then
       If TextBoxName.Text = Empty Then
           i = 0
       Else
           i = i - 1
       End If
       Exit Sub
   End If
   i = i + 1
   If i = 3 Then
       t1 = Mid(TextBoxName.Text, 1, 2)
       t2 = Mid(TextBoxName.Text, 3, 1)
       TextBoxName.Text = Trim$(t1) & "/" & t2
       TextBoxName.SelStart = 4
       t2 = Empty
   ElseIf i = 6 Then
       t1 = Mid(TextBoxName.Text, 1, 5)
       t2 = Mid(TextBoxName.Text, 6, 1)
       TextBoxName.Text = Trim$(t1) & "/" & t2
       TextBoxName.SelStart = 7
       End If
   If i = 11 Then Exit Sub
End Sub
Public Function DateValidation(TextBoxName As TextBox) As Boolean
   If IsDate(Trim$(TextBoxName.Text)) = False Then
       MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."
       TextBoxName.SetFocus
       DateValidation = False
   ElseIf Not Len(Trim$(TextBoxName.Text)) = 10 Then
       MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."
       TextBoxName.SetFocus
       DateValidation = False
   Else
       DateValidation = True
   End If
End Function
Private Sub Text1_KeyPress(KeyAscii As Integer)
Call AutoDate(Text1, 0)
End Sub
Private Sub Text1_LostFocus()
Call DateValidation(Text1)
End Sub

طباعة النص على النموذج بألوان مختلفة

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

Sub Form_Paint()
Dim i As Integer, X As Integer, Y As Integer
Dim C As String
Cls
For i = 0 To 91
X = CurrentX
Y = CurrentY
C = Chr(i)
'Line -(X + TextWidth(C), Y = TextHeight(C)), _
QBColor(Rnd * 16), BF
CurrentX = X
CurrentY = Y
ForeColor = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
Print "منتدى الإبداع الإسلامي   منتدى الإبداع الإسلامي    "
Next
End Sub

مربع نص ثلاثي أبعاد

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

'Set form's AutoRedraw property toTrue
Sub PaintControl3D(frm As Form, Ctl As Control)
' This Sub draws lines around controls to make them 3d

' darkgrey, upper - horizontal
frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _
Ctl.Width, Ctl.Top - 15), &H808080, BF
' darkgrey, left - vertical
frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _
Ctl.Top + Ctl.Height), &H808080, BF
' white, right - vertical
frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF
' white, lower - horizontal
frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF

End Sub

Sub PaintForm3D(frm As Form)
' This Sub draws lines around the Form to make it 3d

' white, upper - horizontal
frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF
' 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
' darkgrey, lower - horizontal
frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _
frm.ScaleHeight - 15), &H808080, BF

End Sub

'DEMO USAGE
'Add 1 label and 1 textbox


Private Sub Form_Load()

Me.AutoRedraw = True
PaintForm3D Me
PaintControl3D Me, Label1 'Label1 is name of label
PaintControl3D Me, Text1 'Text1 is name of textbox

End Sub

منع المسافة في مربع النص

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

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

أخفاء شريط المهام

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

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

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

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

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

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

فتح السيدي روم وإغلاقة

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

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Public Sub OpenCDDriveDoor(ByVal State As Boolean)
If State = True Then
Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
Else
Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
End If
End Sub

Private Sub Command1_Click()
OpenCDDriveDoor (True)
End Sub

Private Sub Command2_Click()
OpenCDDriveDoor (False)
End Sub

تشغيل ملف فيديو في Picture

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

Private Sub Form_Load()
MMControl1.FileName = ("c:\FileName.dat")
MMControl1.Command = "open"
MMControl1.hWndDisplay = Picture1.hWnd
End Sub

تشغيل ملف من نوع ميديا

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

Private Sub Form_Load()
MMControl1.Visible = False
MMControl1.DeviceType = "sequencer"
MMControl1.FileName = ("c:\FileName.mid")
MMControl1.Command = "open"
MMControl1.Command = "play"
End Sub

يبدو ان الاخ professional VB99 يتجاهل الجميع وكأنه لم يقرأ شئ <_<

التحكم في رفع الصوت وقصرة

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

Private Declare Function waveOutSetVolume Lib "Winmm.dll" (ByVal DevID As Integer, ByVal Vol As Long) As Long

Sub SetVol(Volume As Long)
Dim Vol&
Vol = CLng("&H" & Hex(Volume + 65536))
waveOutSetVolume 0, Vol
End Sub

Private Sub Command1_Click()
SetVol Text1.Text
End Sub

Private Sub Form_Load()
Text1.Text = "ضع قيمة عددية تنحصر ما بين 0 و 65536"
End Sub

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

على هذاالرابط أيضاً مجموعة قيمة من الأكواد

أكواد × أكواد

شكراً على المكتبة القيمة

تحياتي (h)

شكرا لكم كلكم بس انا كنت اريد ان اصنع مكتبه من تصميمي لكي انشرها

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