كود عمل صليب داخل النموذج :
Private Sub Form_Mouse****(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
---------------------------------------------------------------------------------
كودان لمعالجة المشاكل :
On Error Resume Next
Kill "C:\Exmaple.bmp"
Or
On Error Goto Error
Kill "C:\Exmaple.bmp"
Error:
---------------------------------------------------------------------------------
كود التأكد من وجود ملف :
If Dir(myfilename, vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If
---------------------------------------------------------------------------------
كود جعل الجملة عمودية :
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
---------------------------------------------------------------------------------
كود اخفاء مؤشر الفأرة في تطبيق الفيجول بيسك :
قسم التعاريف :
Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long
اخفاء :
x = ShowCursor(False)
اظهار :
x = ShowCursor(True)
---------------------------------------------------------------------------------
كود تحديد دقت عرض الشاشة :
Dim x, y As Integer
x = Screen.Width / 15
y = Screen.Height / 15
If x = 640 And y = 480 Then MsgBox ("640 * 480")
If x = 800 And y = 600 Then MsgBox ("800 * 600")
If x = 1024 And y = 768 Then MsgBox ("1024 * 768")
---------------------------------------------------------------------------------
كود تحريك النموذج Form عن طريق الماوس Mouse :
قم بنسخ الكود التالي للموديول Module :
Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
قم بكتابة الكود التالي وليكن عند الحدث MouseDown_Event والخاص مثلا بأداة PictureBox
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
---------------------------------------------------------------------------------
كود تشغيل ملفات الصوت .Wav
بنسخ الكود التالي للموديول Module :
Public Declare Function playa Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Sub PlayWav(path As String)
Dim SafeFile As String
file$ = Dir(path$)
If file$ <> "" Then Call playa(WavFile$, SND_FLAG)
End Sub
لتشغيل أي ملف صوت قم بكتابة الأمر التالي، مع تغيير اسم ومسار ملف الصوت المراد تشغيله:
Call PlayWavFile("D:\songs\nsync\pop.wav")
---------------------------------------------------------------------------------
this code is to unload form in crazy way :
Private Sub Form_Unload(Cancel As Integer)
Frm.WindowState = 0
Frm.**** = 0
Frm.Top = 0
For X = 1 To 5000 Step 500
Frm.**** = X
Frm.Top = X
Next X
For Y = 5000 To 1 Step -100
Frm.**** = Y
Frm.Top = Y
Frm.**** = X
Frm.Top = X
Next Y
For z = 0 To 10000 Step 500
Frm.Height = z
Frm.**** = z
Frm.Width = z
Frm.Top = z
Frm.**** = X
Frm.Top = X
Frm.**** = Y
Frm.Top = Y
Next z
For q = 10000 To 4000 Step -100
Frm.Height = q
Frm.**** = q
Frm.Width = q
Frm.Top = q
Next q
For d = 1 To 2000 Step 100
Frm.**** = X
Frm.**** = Y
Frm.**** = z
Frm.**** = q
Frm.**** = d
Frm.Height = X
Frm.Height = Y
Frm.Height = z
Frm.Height = q
Frm.Height = d
Frm.Width = X
Frm.Width = Y
Frm.Width = z
Frm.Width = q
Frm.Width = d
Frm.Top = X
Frm.Top = Y
Frm.Top = z
Frm.Top = q
Frm.Top = d
Next d
For k = 2000 To 1 Step -100
Frm.**** = X
Frm.**** = Y
Frm.**** = z
Frm.**** = q
Frm.**** = k
Frm.Height = X
Frm.Height = Y
Frm.Height = z
Frm.Height = q
Frm.Height = k
Frm.Width = X
Frm.Width = Y
Frm.Width = z
Frm.Width = q
Frm.Width = k
Frm.Top = X
Frm.Top = Y
Frm.Top = z
Frm.Top = q
Frm.Top = k
Next k
End
End Sub
---------------------------------------------------------------------------------
كود بدا التشغيل :
في الموديل :
Option Explicit
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long
Private Const READ_CONTROL = &H20000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
Private Const RunPath = "Software\Microsoft\Windows\CurrentVersion\Run\"
Private Const HKLM = &H80000002
' استخدم الامر التالي لالغاء التشغيل التلقائي
Public Sub DoNotRun(ProgramName As String)
Dim hKey As Long
Dim Ret As Long
' فتح المفتاح المطلوب
Ret = RegOpenKeyEx(HKLM, RunPath, 0, KEY_ALL_ACCESS, hKey)
' حذفها من مسجل النظام.
Ret = RegDeleteValue(hKey, ProgramName)
' إغلاق المفتاح
RegCloseKey hKey
End Sub
Public Sub RunWhenStartup(ProgramName As String, ProgramPath As String)
Dim hKey As Long
Dim Ret As Long
' فتح المفتاح المطلوب
Ret = RegOpenKeyEx(HKLM, RunPath, 0, KEY_ALL_ACCESS, hKey)
' إنشاء قيمة جديدة بإسم البرنامج وعنوانه.
Ret = RegSetValueEx(hKey, ProgramName, 0&, 1, ProgramPath, Len(ProgramPath)) 'LenB(StrConv(TheData, vbFromUnicode)) + 1)
' إغلاق المفتاح
RegCloseKey hKey
End Sub
------------
في الفورم :
RunWhenStartup "عنوان", App.Path & "\" & App.EXEName & ".exe"
---------------------------------------------------------------------------------
إنشاء مربع نص وقت تنفيذ البرنامج
Private Sub Form_Load()
Form1.Controls.Add "VB.textbox", "Textcreate", Form1
Form1!Textcreate.Visible = True
End Sub
---------------------------------------------------------------------------------
مسح ما يوجد داخل كل مربعات النص الموجودة على الفورم
Public Sub ClearTextBoxes(frm As Form)
Dim c As Control
For Each c In frm
If TypeOf c Is TextBox Then c.Text = ""
Next c
End Sub
Private Sub Command1_Click()
Call ClearTextBoxes(Form1)
End Sub
---------------------------------------------------------------------------------
صنع فجوة داخل الفورم (دائرة - مربع - مستطيل)
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
Const RGN_DIFF = 4
Dim lOriginalForm As Long
Dim ltheHole As Long
Dim lNewForm As Long
Dim lFwidth As Single
Dim lFHeight As Single
Dim lborder_width As Single
Dim ltitle_height As Single
On Error GoTo Trap
lFwidth = ScaleX(Width, vbTwips, vbPixels)
lFHeight = ScaleY(Height, vbTwips, vbPixels)
lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
lborder_width = (lFHeight - ScaleWidth) / 2
ltitle_height = lFHeight - lborder_width - ScaleHeight
Select Case AreaType
Case "Elliptic"
ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RectAngle"
ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RoundRect"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
Case "Circle"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
Case Else
MsgBox "Unknown Shape!!"
Exit Function
End Select
lNewForm = CreateRectRgn(0, 0, 0, 0)
CombineRgn lNewForm, lOriginalForm, ltheHole, RGN_DIFF
SetWindowRgn hWnd, lNewForm, True
Me.Refresh
fMakeATranspArea = True
Exit Function
Trap:
MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description
End Function
Private Sub Form_Load()
Dim lParam(1 To 6) As Long
lParam(1) = 100
lParam(2) = 208
lParam(3) = 50
lParam(4) = 50
lParam(5) = 666
lParam(6) = 555
'Call fMakeATranspArea("RoundRect", lParam())
'Call fMakeATranspArea("RectAngle", lParam())
'Call fMakeATranspArea("Circle", lParam())
Call fMakeATranspArea("Elliptic", lParam())
End Sub
---------------------------------------------------------------------------------
رسم دوائر ملونة رائعة جداً باستخدام الماوس
Private Sub Command1_Click()
Form1.Cls
End Sub
Private Sub Form_Mouse****(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
i = Rnd * 15
If Button = 1 Then
Me.Circle (X, Y), 200, QBColor(i)
End If
End Sub
---------------------------------------------------------------------------------
كود بسيط لجعل الفورم في المقدمة
Private Declare Sub 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)
Private Sub Form_Load()
Timer1.Interval = 1
End Sub
Private Sub Timer1_Timer()
SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3
End Sub
---------------------------------------------------------------------------------
تحريك Label بشكل طولي
Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Label1.**** 2000, Label1.Top - 100
If Label1.Top < 0 Then
Label1.Top = Form1.Height
End If
End Sub
---------------------------------------------------------------------------------
حريك 2 Label مع تغيير ألوانهما
Private Sub Form_Load()
Timer1.Interval = 100
Timer2.Interval = 100
Label1 = "Welcome"
Label2 = "Good Bey"
End Sub
Private Sub Timer1_Timer()
Label1.ForeColor = QBColor(Rnd * 15)
Label1.**** = Label1.**** + 10
End Sub
Private Sub Timer2_Timer()
Label2.ForeColor = QBColor(Rnd * 10)
Label2.**** = Label2.**** - 10
End Sub
---------------------------------------------------------------------------------
ظهور الـ Label في أماكن عشوائية وبألوان عشوائية
Private Sub Form_Load()
Timer1.Interval = 250
End Sub
Private Sub Timer1_Timer()
Randomize
Label1.ForeColor = QBColor(Rnd * 13)
Label1.**** = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Label1.**** Rnd * 10000, Rnd * 9000, Rnd * 12000, Rnd * 9000
End Sub
---------------------------------------------------------------------------------
ظهور الفورم بأحجام وألوان عشوائية، تخاريف
Private Sub Form_Load()
Timer1.Interval = 250
End Sub
Private Sub Timer1_Timer()
Randomize
Me.BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.**** Rnd * 12000, Rnd * 9000, Rnd * 12000, Rnd * 9000
End Sub
---------------------------------------------------------------------------------
كود بسيط لالتقاط صورة للشاشة في الحافظة
Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Sub Command1_Click()
keybd_event vbKeySnapshot, 0, 0, 0
DoEvents
End Sub
---------------------------------------------------------------------------------
السماح بكتابة حروف إنجليزية فقط في مربع النص
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
---------------------------------------------------------------------------------
السماح بإدخال تاريخ فقط في مربع النص
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
---------------------------------------------------------------------------------
التقاط ص