v.b.6 codes(4)

لإيقاف الماوس والكي بورد عن العمل لفترة وأعادته مرة اخرة للعمل
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()
DoEvents
' إيقاف لوحة المفاتيح والماوس عن العمل
BlockInput True
' الانتظار عشر ثواني
Sleep 10000
' إعادة لوحة المفاتيح والماوس للعمل مرة أخرى
BlockInput False
End Sub
..........................................................................................
يجعلك عندما تقرب الماوس فوق التست يبتعد
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If Text1.Top = 600 Then ' Move it to the bottom
For i = 600 To Form1.Height - 2 * Text1.Height Step Screen.TwipsPerPixelY
Text1.Top = i ' Change the command button's top property to i
Next i ' Reapeat
Else ' Move it to the top
For i = Form1.Height - 2 * Text1.Height To 600 Step -Screen.TwipsPerPixelY
Text1.Top = i
Next i
End If
End Sub
...........................................................................................
لإظهار وإخفاء الأيقونات (الرموز) على سطح المكتب
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
Private Sub Command1_Click()
'لإخفاء الأيقونات على سطح المكتب
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 0
End Sub
Private Sub Command2_Click()
'لإظهار الأيقونات على سطح المكتب
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 5
End Sub
.........................................................................................
لتشفير وفك تشفير نص
Private Sub Command1_Click()
For i = 1 To Len(Text1.Text)
st1 = Mid(Text1.Text, i, 1)
as1 = Asc(st1)
ch1 = Chr(255 - as1)
st = st + ch1
Next
Text1.Text = st
End Sub
..........................................................................................
لحصر الماوس داخل النموذج (وتستطيع ان تحصرها داخل أي أداة أخرى
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, _
lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, _
lpPoint As Any) As Long
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Sub RestrictMouseRegion(Optional ByVal hWnd As Long = 0)
Dim recTargetWindow As RECT
If hWnd Then
GetClientRect hWnd, recTargetWindow
ClientToScreen hWnd, recTargetWindow
ClientToScreen hWnd, recTargetWindow.Right
ClipCursor recTargetWindow
Else
ClipCursor ByVal 0&
End If
End Sub
Private Sub Form_Load()
RestrictMouseRegion (Me.hWnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
RestrictMouseRegion
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 Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub
' لإظهار شريط المهام
Private Sub Command2_Click()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub
..........................................................................................
لاعطاء كلمة مرور للبرنامج
rivate Sub Form_Load()
'تعريف المتغيرات
Dim s As Integer
Dim passw As String
'اعطاء قيمة اولية
s = 1
'بدية التكرار واختبار ووضع كلمة المرور
Do Until (s = 5 Or passw = "هنا ضع كلمة المرور")
'عرض مربع الادخال لكتابة كلمة المرور
passw = InputBox("ادخل كلمة المرور الى قاعدة البيانات", "كلمة مرور مطلوبة")
'مقدار زيادة لستمرار التكرار
s = s + 1
Loop
If s = 5 Then
'عرض رسالة للمستخدم بعد التكرار دون تحقق الشرط
MsgBox "كلمة المرور التي ادخلتها خاطئة... الرجاء حاول مرة أخرى", vbOKOnly, "خطأ في كلمة المرور"
End
'عرض النموذج بعد التأكد من تحقق الشرط
Form1.Show "form1"
'خروج من التكرار
End If
End Sub
...........................................................................................
لأختبار بطاقة اخراج الصوت من الجهاز
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Sub Command1_Click()
'Get the number of installed waveout devices
ret& = waveOutGetNumDevs
If ret& > 0 Then
MsgBox "يوجد بطاقة لإخراج الصوت مثبتة على هذا الجهاز"
Else
MsgBox "للأسف لايوجد بطاقة لإخراج الصوت على هذا الجهاز"
End If
End Sub
...........................................................................................